From 4c77dcf9388315411539b513aaac5f48b5c875ad Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 2 Oct 2009 23:34:35 +0000 Subject: [PATCH] merge GF.Grammar.API into GF.Grammar --- src/GF/Compile/AbsCompute.hs | 4 +-- src/GF/Compile/TypeCheck.hs | 12 ++++---- src/GF/Grammar.hs | 27 ++++++----------- src/GF/Grammar/API.hs | 58 ------------------------------------ src/GF/Grammar/Printer.hs | 14 +++++++++ src/GFI.hs | 25 +++++++++++----- 6 files changed, 49 insertions(+), 91 deletions(-) delete mode 100644 src/GF/Grammar/API.hs diff --git a/src/GF/Compile/AbsCompute.hs b/src/GF/Compile/AbsCompute.hs index 3f4c6d061..bfc824d82 100644 --- a/src/GF/Compile/AbsCompute.hs +++ b/src/GF/Compile/AbsCompute.hs @@ -36,10 +36,10 @@ import Text.PrettyPrint tracd m t = t -- tracd = trace -compute :: Grammar -> Exp -> Err Exp +compute :: SourceGrammar -> Exp -> Err Exp compute = computeAbsTerm -computeAbsTerm :: Grammar -> Exp -> Err Exp +computeAbsTerm :: SourceGrammar -> Exp -> Err Exp computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] -- | a hack to make compute work on source grammar as well diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs index 05b0b288a..aefcf4d25 100644 --- a/src/GF/Compile/TypeCheck.hs +++ b/src/GF/Compile/TypeCheck.hs @@ -49,7 +49,7 @@ cont2val = type2val . cont2exp -- some top-level batch-mode checkers for the compiler -justTypeCheck :: Grammar -> Exp -> Val -> Err Constraints +justTypeCheck :: SourceGrammar -> Exp -> Val -> Err Constraints justTypeCheck gr e v = do (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v (constrs1,_) <- unifyVal constrs0 @@ -59,25 +59,25 @@ notJustMeta (c,k) = case (c,k) of (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False _ -> True -grammar2theory :: Grammar -> Theory +grammar2theory :: SourceGrammar -> Theory grammar2theory gr (m,f) = case lookupFunType gr m f of Ok t -> return $ type2val t Bad s -> case lookupCatContext gr m f of Ok cont -> return $ cont2val cont _ -> Bad s -checkContext :: Grammar -> Context -> [Message] +checkContext :: SourceGrammar -> Context -> [Message] checkContext st = checkTyp st . cont2exp -checkTyp :: Grammar -> Type -> [Message] +checkTyp :: SourceGrammar -> Type -> [Message] checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType -checkDef :: Grammar -> Fun -> Type -> [Equation] -> [Message] +checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message] checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs let (bs,css) = unzip bcs (constrs,_) <- unifyVal (concat css) return $ filter notJustMeta constrs -checkConstrs :: Grammar -> Cat -> [Ident] -> [String] +checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String] checkConstrs gr cat _ = [] ---- check constructors! diff --git a/src/GF/Grammar.hs b/src/GF/Grammar.hs index 71c95a73d..c540f77b8 100644 --- a/src/GF/Grammar.hs +++ b/src/GF/Grammar.hs @@ -12,27 +12,18 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Grammar ( - -module GF.Infra.Ident, -module GF.Grammar.Grammar, -module GF.Grammar.Values, -module GF.Grammar.Macros, -module GF.Grammar.MMacros, -module GF.Grammar.Printer, - -Grammar - - ) where +module GF.Grammar + ( module GF.Infra.Ident, + module GF.Grammar.Grammar, + module GF.Grammar.Values, + module GF.Grammar.Macros, + module GF.Grammar.MMacros, + module GF.Grammar.Printer + ) where +import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Values import GF.Grammar.Macros -import GF.Infra.Ident import GF.Grammar.MMacros import GF.Grammar.Printer - -type Grammar = SourceGrammar --- - - - diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs deleted file mode 100644 index 8dc86c10e..000000000 --- a/src/GF/Grammar/API.hs +++ /dev/null @@ -1,58 +0,0 @@ -module GF.Grammar.API ( - Grammar, - emptyGrammar, - checkTerm, - computeTerm, - showTerm, - TermPrintStyle(..), TermPrintQual(..), - ) where - -import GF.Infra.Ident -import GF.Infra.CheckM -import GF.Infra.Modules (greatestResource) -import GF.Compile.GetGrammar -import GF.Grammar.Macros -import GF.Grammar.Parser -import GF.Grammar.Printer -import GF.Grammar.Grammar - -import GF.Compile.Rename (renameSourceTerm) -import GF.Compile.CheckGrammar (inferLType) -import GF.Compile.Compute (computeConcrete) - -import GF.Data.Operations -import GF.Infra.Option - -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint - -type Grammar = SourceGrammar - -emptyGrammar :: Grammar -emptyGrammar = emptySourceGrammar - -checkTerm :: Grammar -> Term -> Err Term -checkTerm gr t = do - mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr - checkTermAny gr mo t - -checkTermAny :: Grammar -> Ident -> Term -> Err Term -checkTermAny gr m t = (fmap fst . runCheck) $ do - t <- renameSourceTerm gr m t - (t,_) <- inferLType gr [] t - return t - -computeTerm :: Grammar -> Term -> Err Term -computeTerm = computeConcrete - -showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String -showTerm style q t = render $ - case style of - TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] - TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] - TermPrintDefault -> ppTerm q 0 t - -data TermPrintStyle - = TermPrintTable - | TermPrintAll - | TermPrintDefault diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs index e0edadbec..80195b2d1 100644 --- a/src/GF/Grammar/Printer.hs +++ b/src/GF/Grammar/Printer.hs @@ -18,6 +18,8 @@ module GF.Grammar.Printer , ppPatt , ppValue , ppConstrs + + , showTerm, TermPrintStyle(..) ) where import GF.Infra.Ident @@ -301,3 +303,15 @@ getLet :: Term -> ([LocalDef], Term) getLet (Let l e) = let (ls,e') = getLet e in (l:ls,e') getLet e = ([],e) + +showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String +showTerm style q t = render $ + case style of + TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] + TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] + TermPrintDefault -> ppTerm q 0 t + +data TermPrintStyle + = TermPrintTable + | TermPrintAll + | TermPrintDefault diff --git a/src/GFI.hs b/src/GFI.hs index 170e4be34..86f9614ed 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -7,12 +7,16 @@ import GF.Command.Commands import GF.Command.Abstract import GF.Command.Parse import GF.Data.ErrM -import GF.Grammar.API -import GF.Grammar.Lexer -import GF.Grammar.Parser +import GF.Grammar hiding (Ident) +import GF.Grammar.Parser (runP, pExp) +import GF.Compile.Rename +import GF.Compile.CheckGrammar +import GF.Compile.Compute (computeConcrete) import GF.Infra.Dependencies +import GF.Infra.CheckM import GF.Infra.UseIO import GF.Infra.Option +import GF.Infra.Modules (greatestResource) import GF.System.Readline import GF.Text.Coding @@ -107,9 +111,16 @@ loop opts gfenv0 = do pOpts style q ws = (style,q,unwords ws) (style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0)) + + checkComputeTerm gr t = do + mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr + ((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t + inferLType gr [] t + computeConcrete sgr t + case runP pExp (BS.pack s) of Left (_,msg) -> putStrLn msg - Right t -> case checkTerm sgr (codeTerm (decode gfenv) t) >>= computeTerm sgr of + Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of Ok x -> putStrLn $ enc (showTerm style q x) Bad s -> putStrLn $ enc s loopNewCPU gfenv @@ -128,7 +139,7 @@ loop opts gfenv0 = do -- other special commands, working on GFEnv "e":_ -> loopNewCPU $ gfenv { - commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar + commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar } "dc":f:ws -> do @@ -220,7 +231,7 @@ prompt env abs = abstractName (multigrammar env) data GFEnv = GFEnv { - sourcegrammar :: Grammar, -- gfo grammar -retain + sourcegrammar :: SourceGrammar, -- gfo grammar -retain commandenv :: CommandEnv, history :: [String], cputime :: Integer, @@ -235,7 +246,7 @@ emptyGFEnv = do #else let coding = UTF_8 #endif - return $ GFEnv emptyGrammar (mkCommandEnv coding emptyPGF) [] 0 coding + return $ GFEnv emptySourceGrammar (mkCommandEnv coding emptyPGF) [] 0 coding encode = encodeUnicode . coding decode = decodeUnicode . coding