diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/CF/PrLBNF.hs | 43 | ||||
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 23 |
2 files changed, 48 insertions, 18 deletions
diff --git a/src/GF/CF/PrLBNF.hs b/src/GF/CF/PrLBNF.hs index 59067c39b..701674a52 100644 --- a/src/GF/CF/PrLBNF.hs +++ b/src/GF/CF/PrLBNF.hs @@ -11,14 +11,16 @@ import Char -- Printing CF grammars generated from GF as LBNF grammar for BNFC. -- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 --- With a primitive error messaging, by rules and rule tails commented out +-- With primitive error messaging, by rules and rule tails commented out prLBNF :: CF -> String -prLBNF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function +prLBNF cf = unlines $ (map (prCFRule cs)) $ rulesOfCF cf --- no literal recogn function + where + cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rulesOfCF cf] -- a hack to hide the LBNF details prBNF :: CF -> String -prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOfCF +prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF where unLBNF r = case r of "---":ts -> ts @@ -26,25 +28,35 @@ prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOf c:ts -> c : unLBNF ts _ -> r -prCFRule :: CFRule -> String -prCFRule (fun,(cat,its)) = - prCFFun fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax - unwords (map prCFItem its) +++ ";" +catId ((CFCat ((CIQ _ c),l))) = c -prCFFun :: CFFun -> String -prCFFun (CFFun (t, p)) = case t of - AC (CIQ _ x) -> prId True x - AD (CIQ _ x) -> prId True x +prCFRule :: [Ident] -> CFRule -> String +prCFRule cs (fun,(cat,its)) = + prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax + unwords (map (prCFItem cs) its) +++ ";" + +prCFFun :: CFCat -> CFFun -> String +prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of + AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) + AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) _ -> prErr True $ prt t + where + lab = prLab l + f2 f = if null lab then "" else f + prP = concatMap show prId b i = case i of - IC "Int" -> "Integer" + IC "Int" -> "Integer" + IC "#Var" -> "Ident" + IC "Var" -> "Ident" + IC "id_" -> "_" IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else "" _ -> prErr b $ prt i prLab i = case i of L (IC "s") -> "" --- - _ -> "_" ++ prt i + L (IC "_") -> "" --- + _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else "" -- just comment out the rest if you cannot interpret the function name in LBNF -- two versions, depending on whether in the beginning of a rule or elsewhere; @@ -55,8 +67,9 @@ prErr b s = (if b then "" else " ;") +++ "---" +++ s prCFCat :: Bool -> CFCat -> String prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ---- -prCFItem (CFNonterm c) = prCFCat False c -prCFItem (CFTerm a) = prRegExp a +-- if a category does not have a production of its own, we replace it by Ident +prCFItem cs (CFNonterm c) = if elem (catId c) cs then prCFCat False c else "Ident" +prCFItem _ (CFTerm a) = prRegExp a prRegExp (RegAlts tt) = case tt of [t] -> prQuotedString t diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 811437f57..3a4706f27 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -78,15 +78,32 @@ checkAbsInfo st m (c,info) = do case info of AbsCat (Yes cont) _ -> mkCheck "category" $ checkContext st cont ---- also cstrs - AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ - checkTyp st typ ----- ++ - ----- checkEquation st (m,c) d ---- also if there's no def! + AbsFun (Yes typ0) md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "function" $ + checkTyp st typ ++ + case md of + Yes d -> checkEquation st (m,c) d + _ -> [] + return $ (c,AbsFun (Yes typ) md) _ -> return (c,info) where mkCheck cat ss = case ss of [] -> return (c,info) ["[]"] -> return (c,info) ---- _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + compAbsTyp g t = case t of + Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod x a b -> do + a' <- compAbsTyp g a + b' <- compAbsTyp ((x,Vr x):g) b + return $ Prod x a' b' + Abs _ _ -> return t + _ -> composOp (compAbsTyp g) t + checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check () checkCompleteGrammar abs cnc = mapM_ checkWarn $ |