From c0d22bec2dcf176f75a0deff27aa8064f945d5aa Mon Sep 17 00:00:00 2001 From: krasimir Date: Thu, 19 Jun 2008 12:48:29 +0000 Subject: [PATCH] split the Exp type to Tree and Expr --- GF.cabal | 2 +- src-3.0/GF/Command/Abstract.hs | 2 +- src-3.0/GF/Command/Commands.hs | 26 +- src-3.0/GF/Command/Interpreter.hs | 24 +- src-3.0/GF/Command/Parse.hs | 6 +- src-3.0/GF/Compile/GFCCtoJS.hs | 2 +- src-3.0/GF/Compile/GenerateFCFG.hs | 6 +- src-3.0/GF/Compile/GeneratePMCFG.hs | 6 +- src-3.0/GF/Compile/GrammarToGFCC.hs | 23 +- src-3.0/GFI.hs | 494 ++++++++++++------------ src-3.0/PGF.hs | 34 +- src-3.0/PGF/Data.hs | 62 ++- src-3.0/PGF/Expr.hs | 202 ++++++++++ src-3.0/PGF/ExprSyntax.hs | 73 ---- src-3.0/PGF/Generate.hs | 18 +- src-3.0/PGF/Linearize.hs | 26 +- src-3.0/PGF/Macros.hs | 10 +- src-3.0/PGF/Parsing/FCFG.hs | 4 +- src-3.0/PGF/Parsing/FCFG/Active.hs | 4 +- src-3.0/PGF/Parsing/FCFG/Incremental.hs | 6 +- src-3.0/PGF/Parsing/FCFG/Utilities.hs | 12 +- src-3.0/PGF/Raw/Convert.hs | 26 +- src-3.0/PGF/ShowLinearize.hs | 22 +- 23 files changed, 613 insertions(+), 477 deletions(-) create mode 100644 src-3.0/PGF/Expr.hs delete mode 100644 src-3.0/PGF/ExprSyntax.hs diff --git a/GF.cabal b/GF.cabal index bd928df7a..e9bf84b80 100644 --- a/GF.cabal +++ b/GF.cabal @@ -37,7 +37,7 @@ library PGF.Parsing.FCFG.Active PGF.Parsing.FCFG.Incremental PGF.Parsing.FCFG - PGF.ExprSyntax + PGF.Expr PGF.Raw.Parse PGF.Raw.Print PGF.Raw.Convert diff --git a/src-3.0/GF/Command/Abstract.hs b/src-3.0/GF/Command/Abstract.hs index 8643a649f..b26499d54 100644 --- a/src-3.0/GF/Command/Abstract.hs +++ b/src-3.0/GF/Command/Abstract.hs @@ -24,7 +24,7 @@ data Value deriving (Eq,Ord,Show) data Argument - = AExp Exp + = ATree Tree | ANoArg | AMacro Ident deriving (Eq,Ord,Show) diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs index b66d4764d..27c8e5fb4 100644 --- a/src-3.0/GF/Command/Commands.hs +++ b/src-3.0/GF/Command/Commands.hs @@ -20,7 +20,7 @@ import GF.Compile.Export import GF.Infra.Option (noOptions) import GF.Infra.UseIO import GF.Data.ErrM ---- -import PGF.ExprSyntax (readExp) +import PGF.Expr (readTree) import GF.Command.Abstract import GF.Text.Lexing import GF.Text.Transliterations @@ -29,12 +29,12 @@ import GF.Data.Operations import Data.Maybe import qualified Data.Map as Map -import System +import System.Cmd -type CommandOutput = ([Exp],String) ---- errors, etc +type CommandOutput = ([Tree],String) ---- errors, etc data CommandInfo = CommandInfo { - exec :: [Option] -> [Exp] -> IO CommandOutput, + exec :: [Option] -> [Tree] -> IO CommandOutput, synopsis :: String, syntax :: String, explanation :: String, @@ -192,7 +192,7 @@ allCommands pgf = Map.fromList [ ("full","give full information of the commands") ], exec = \opts ts -> return ([], case ts of - [t] -> let co = showExp t in + [t] -> let co = showTree t in case lookCommand co (allCommands pgf) of ---- new map ??!! Just info -> commandHelp True (co,info) _ -> "command not found" @@ -381,9 +381,9 @@ allCommands pgf = Map.fromList [ s <- readFile file return $ case opts of _ | isOpt "lines" opts && isOpt "tree" opts -> - fromTrees [t | l <- lines s, Just t <- [readExp l]] + fromTrees [t | l <- lines s, Just t <- [readTree l]] _ | isOpt "tree" opts -> - fromTrees [t | Just t <- [readExp s]] + fromTrees [t | Just t <- [readTree s]] _ | isOpt "lines" opts -> fromStrings $ lines s _ -> fromString s, flags = [("file","the input file name")] @@ -469,7 +469,7 @@ allCommands pgf = Map.fromList [ _ -> linearize pgf lang treebank opts t = unlines $ - (abstractName pgf ++ ": " ++ showExp t) : + (abstractName pgf ++ ": " ++ showTree t) : [lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] optRestricted opts = restrictPGF (hasLin pgf (mkCId (optLang opts))) pgf @@ -483,11 +483,11 @@ allCommands pgf = Map.fromList [ optNum opts = valIntOpts "number" 1 opts optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 - fromTrees ts = (ts,unlines (map showExp ts)) - fromStrings ss = (map EStr ss, unlines ss) - fromString s = ([EStr s], s) - toStrings ts = [s | EStr s <- ts] - toString ts = unwords [s | EStr s <- ts] + fromTrees ts = (ts,unlines (map showTree ts)) + fromStrings ss = (map (Lit . LStr) ss, unlines ss) + fromString s = ([Lit (LStr s)], s) + toStrings ts = [s | Lit (LStr s) <- ts] + toString ts = unwords [s | Lit (LStr s) <- ts] prGrammar opts = case opts of _ | isOpt "cats" opts -> unwords $ categories pgf diff --git a/src-3.0/GF/Command/Interpreter.hs b/src-3.0/GF/Command/Interpreter.hs index ee354bd45..e1a06a205 100644 --- a/src-3.0/GF/Command/Interpreter.hs +++ b/src-3.0/GF/Command/Interpreter.hs @@ -24,7 +24,7 @@ data CommandEnv = CommandEnv { multigrammar :: PGF, commands :: Map.Map String CommandInfo, commandmacros :: Map.Map String CommandLine, - expmacros :: Map.Map String Exp + expmacros :: Map.Map String Tree } mkCommandEnv :: PGF -> CommandEnv @@ -64,18 +64,18 @@ interpretPipe env cs = do appLine es = map (map (appCommand es)) -- macro definition applications: replace ?i by (exps !! i) -appCommand :: [Exp] -> Command -> Command +appCommand :: [Tree] -> Command -> Command appCommand xs c@(Command i os arg) = case arg of - AExp e -> Command i os (AExp (app e)) - _ -> c + ATree e -> Command i os (ATree (app e)) + _ -> c where app e = case e of - EMeta i -> xs !! i - EApp f as -> EApp f (map app as) - EAbs x b -> EAbs x (app b) + Meta i -> xs !! i + Fun f as -> Fun f (map app as) + Abs x b -> Abs x (app b) -- return the trees to be sent in pipe, and the output possibly printed -interpret :: CommandEnv -> [Exp] -> Command -> IO CommandOutput +interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput interpret env trees0 comm = case lookCommand co comms of Just info -> do checkOpts info @@ -100,17 +100,17 @@ interpret env trees0 comm = case lookCommand co comms of -- analyse command parse tree to a uniform datastructure, normalizing comm name --- the env is needed for macro lookup -getCommand :: CommandEnv -> Command -> [Exp] -> (String,[Option],[Exp]) +getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree]) getCommand env co@(Command c opts arg) ts = (getCommandOp c,opts,getCommandArg env arg ts) -getCommandArg :: CommandEnv -> Argument -> [Exp] -> [Exp] +getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree] getCommandArg env a ts = case a of AMacro m -> case Map.lookup m (expmacros env) of Just t -> [t] _ -> [] - AExp t -> [t] -- ignore piped - ANoArg -> ts -- use piped + ATree t -> [t] -- ignore piped + ANoArg -> ts -- use piped -- abbreviation convention from gf commands getCommandOp s = case break (=='_') s of diff --git a/src-3.0/GF/Command/Parse.hs b/src-3.0/GF/Command/Parse.hs index 1b603f411..eaf4cba84 100644 --- a/src-3.0/GF/Command/Parse.hs +++ b/src-3.0/GF/Command/Parse.hs @@ -1,7 +1,7 @@ module GF.Command.Parse(readCommandLine, pCommand) where -import PGF.ExprSyntax -import PGF.Data(Exp) +import PGF.Expr +import PGF.Data(Tree) import GF.Command.Abstract import Data.Char @@ -43,6 +43,6 @@ pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where pArgument = RP.option ANoArg - (fmap AExp (pExp False) + (fmap ATree (pTree False) RP.<++ (RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent)) diff --git a/src-3.0/GF/Compile/GFCCtoJS.hs b/src-3.0/GF/Compile/GFCCtoJS.hs index 024de7273..8259e7385 100644 --- a/src-3.0/GF/Compile/GFCCtoJS.hs +++ b/src-3.0/GF/Compile/GFCCtoJS.hs @@ -31,7 +31,7 @@ pgf2js pgf = abstract2js :: String -> Abstr -> JS.Expr abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] -absdef2js :: (CId,(Type,Exp)) -> JS.Property +absdef2js :: (CId,(Type,Expr)) -> JS.Property absdef2js (f,(typ,_)) = let (args,cat) = M.catSkeleton typ in JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)]) diff --git a/src-3.0/GF/Compile/GenerateFCFG.hs b/src-3.0/GF/Compile/GenerateFCFG.hs index 64f824acf..c2854ef3d 100644 --- a/src-3.0/GF/Compile/GenerateFCFG.hs +++ b/src-3.0/GF/Compile/GenerateFCFG.hs @@ -42,7 +42,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats' cats = lincats cnc (abs_defs',conc',cats') = expandHOAS abs_defs conc cats -expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap) +expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap) expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, Map.unions [lins, hoLins, varLins], Map.unions [lincats, hoLincats, varLincat]) @@ -97,7 +97,7 @@ fixHoasFuns (rs, cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args ca | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId fixName n = n -convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar +convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> FGrammar convert abs_defs cnc_defs cat_defs = getFGrammar (loop frulesEnv) where srules = [ @@ -193,7 +193,7 @@ convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) = return ((lbl_path,Right str : lin) : lins) convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = do projectHead lbl_path - toks <- member (strs:[strs' | Var strs' _ <- vars]) + toks <- member (strs:[strs' | Alt strs' _ <- vars]) return ((lbl_path, map Right toks ++ lin) : lins) convertTerm cnc_defs selector (F id) lins = do term <- Map.lookup id cnc_defs convertTerm cnc_defs selector term lins diff --git a/src-3.0/GF/Compile/GeneratePMCFG.hs b/src-3.0/GF/Compile/GeneratePMCFG.hs index 435a06eb1..e0343e8d6 100644 --- a/src-3.0/GF/Compile/GeneratePMCFG.hs +++ b/src-3.0/GF/Compile/GeneratePMCFG.hs @@ -44,7 +44,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats' cats = lincats cnc (abs_defs',conc',cats') = expandHOAS abs_defs conc cats -expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap) +expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap) expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, Map.unions [lins, hoLins, varLins], Map.unions [lincats, hoLincats, varLincat]) @@ -99,7 +99,7 @@ fixHoasFuns (!rs, !cs) = ([FRule (fixName n) ps args cat lins | FRule n ps args | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId fixName n = n -convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar +convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> FGrammar convert abs_defs cnc_defs cat_defs = getFGrammar (List.foldl' (convertRule cnc_defs) emptyFRulesEnv srules) where srules = [ @@ -159,7 +159,7 @@ convertTerm cnc_defs sel ctype (FV vars) lins = do term <- convertTerm cnc_defs sel ctype (S ts) ((lbl_path,lin) : lins) = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) ((lbl_path,lin) : lins) (reverse ts) convertTerm cnc_defs sel ctype (K (KS str)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok str : lin) : lins) convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) = - do toks <- member (strs:[strs' | Var strs' _ <- vars]) + do toks <- member (strs:[strs' | Alt strs' _ <- vars]) return ((lbl_path, map FSymTok toks ++ lin) : lins) convertTerm cnc_defs sel ctype (F id) lins = do term <- Map.lookup id cnc_defs convertTerm cnc_defs sel ctype term lins diff --git a/src-3.0/GF/Compile/GrammarToGFCC.hs b/src-3.0/GF/Compile/GrammarToGFCC.hs index 010393bfd..d14a914f1 100644 --- a/src-3.0/GF/Compile/GrammarToGFCC.hs +++ b/src-3.0/GF/Compile/GrammarToGFCC.hs @@ -119,28 +119,27 @@ mkType :: A.Type -> C.Type mkType t = case GM.typeForm t of Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args) -mkExp :: A.Term -> C.Exp +mkExp :: A.Term -> C.Expr mkExp t = case t of A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs] _ -> case GM.termForm t of Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args)) where - mkAbs [] t = t - mkAbs xs t = C.EAbs [i2i x | x <- xs] t - mkApp c args = case c of - Q _ c -> C.EApp (i2i c) args - QC _ c -> C.EApp (i2i c) args + mkAbs xs t = foldr (C.EAbs . i2i) t xs + mkApp c args = case c of + Q _ c -> foldl C.EApp (C.EVar (i2i c)) args + QC _ c -> foldl C.EApp (C.EVar (i2i c)) args Vr x -> C.EVar (i2i x) - EInt i -> C.EInt i - EFloat f -> C.EFloat f - K s -> C.EStr s + EInt i -> C.ELit (C.LInt i) + EFloat f -> C.ELit (C.LFlt f) + K s -> C.ELit (C.LStr s) Meta (MetaSymb i) -> C.EMeta i _ -> C.EMeta 0 mkPatt p = case p of - A.PP _ c ps -> C.EApp (i2i c) (map mkPatt ps) + A.PP _ c ps -> foldl C.EApp (C.EVar (i2i c)) (map mkPatt ps) A.PV x -> C.EVar (i2i x) A.PW -> C.EVar wildCId - A.PInt i -> C.EInt i + A.PInt i -> C.ELit (C.LInt i) mkContext :: A.Context -> [C.Hypo] mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps] @@ -167,7 +166,7 @@ mkTerm tr = case tr of App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging Abs _ t -> mkTerm t ---- only on toplevel Alts (td,tvs) -> - C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs]) + C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs]) _ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging where mkLab (LIdent l) = case BS.unpack l of diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs index 27a825c12..8bcc7df14 100644 --- a/src-3.0/GFI.hs +++ b/src-3.0/GFI.hs @@ -1,257 +1,237 @@ -module GFI (mainGFI) where - -import GF.Command.Interpreter -import GF.Command.Importing -import GF.Command.Commands -import GF.Command.Abstract -import GF.Command.Parse -import GF.Data.ErrM -import GF.Grammar.API -- for cc command -import GF.Infra.UseIO -import GF.Infra.Option -import GF.System.Readline - -import PGF -import PGF.Data -import PGF.Macros -import PGF.ExprSyntax (readExp) - -import Data.Char -import Data.List(isPrefixOf) -import qualified Data.Map as Map -import qualified Text.ParserCombinators.ReadP as RP -import System.Cmd -import System.CPUTime -import Control.Exception - -import Data.Version -import Paths_gf - -mainGFI :: Options -> [FilePath] -> IO () -mainGFI opts files = do - putStrLn welcome - gfenv <- importInEnv emptyGFEnv opts files - loop opts gfenv - return () - -loop :: Options -> GFEnv -> IO GFEnv -loop opts gfenv0 = do - let env = commandenv gfenv0 - let sgr = sourcegrammar gfenv0 - setCompletionFunction (Just (wordCompletion (commandenv gfenv0))) - s <- fetchCommand (prompt env) - let gfenv = gfenv0 {history = s : history gfenv0} - let loopNewCPU gfenv' = do - cpu' <- getCPUTime - putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") - loop opts $ gfenv' {cputime = cpu'} - let - pwords = case words s of - w:ws -> getCommandOp w :ws - ws -> ws - case pwords of - -- special commands, requiring source grammar in env - "!":ws -> do - system $ unwords ws - loopNewCPU gfenv - "cc":ws -> do - let - (style,term) = case ws of - ('-':w):ws2 -> (pTermPrintStyle w, ws2) - _ -> (TermPrintDefault, ws) - case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe! - Ok x -> putStrLnFlush (showTerm style x) - Bad s -> putStrLnFlush s - loopNewCPU gfenv - "i":args -> do - gfenv' <- case parseOptions args of - Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files - Bad err -> do - putStrLn $ "Command parse error: " ++ err - return gfenv - loopNewCPU gfenv' - - -- other special commands, working on GFEnv - "e":_ -> loopNewCPU $ gfenv { - commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar - } - - "dc":f:ws -> do - case readCommandLine (unwords ws) of - Just comm -> loopNewCPU $ gfenv { - commandenv = env { - commandmacros = Map.insert f comm (commandmacros env) - } - } - _ -> putStrLnFlush "command definition not parsed" >> loopNewCPU gfenv - - "dt":f:"<":ws -> do - case readCommandLine (unwords ws) of - Just [pip] -> do - ip <- interpretPipe env pip - case ip of - (exp:es,_) -> do - if null es then return () else - putStrLnFlush $ "ambiguous definition, selected the first one" - loopNewCPU $ gfenv { - commandenv = env { - expmacros = Map.insert f exp (expmacros env) - } - } - _ -> putStrLnFlush "no value given in definition" >> loopNewCPU gfenv - _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv - - "dt":f:ws -> do - case readExp (unwords ws) of - Just exp -> loopNewCPU $ gfenv { - commandenv = env { - expmacros = Map.insert f exp (expmacros env) - } - } - _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv - - "ph":_ -> mapM_ putStrLnFlush (reverse (history gfenv0)) >> loopNewCPU gfenv - "q":_ -> putStrLnFlush "See you." >> return gfenv - - -- ordinary commands, working on CommandEnv - _ -> do - interpretCommandLine env s - loopNewCPU gfenv - -importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv -importInEnv gfenv opts files - | flag optRetainResource opts = - do src <- importSource (sourcegrammar gfenv) opts files - return $ gfenv {sourcegrammar = src} - | otherwise = - do let opts' = addOptions (setOptimization OptCSE False) opts - cenv0 = commandenv gfenv - pgf0 = multigrammar cenv0 - pgf1 <- importGrammar pgf0 opts' files - putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 - return $ gfenv { commandenv = (mkCommandEnv pgf1) - {commandmacros = commandmacros cenv0, expmacros = expmacros cenv0}} ---- return $ gfenv { commandenv = cenv0 {multigrammar = pgf1} } -- WHY NOT - -welcome = unlines [ - " ", - " * * * ", - " * * ", - " * * ", - " * ", - " * ", - " * * * * * * * ", - " * * * ", - " * * * * * * ", - " * * * ", - " * * * ", - " ", - "This is GF version "++showVersion version++". ", - "Some things may work. " - ] - -prompt env = absname ++ "> " where - absname = case abstractName (multigrammar env) of - "_" -> "" --- created by new Ident handling 22/5/2008 - n -> n - -data GFEnv = GFEnv { - sourcegrammar :: Grammar, -- gfo grammar -retain - commandenv :: CommandEnv, - history :: [String], - cputime :: Integer - } - -emptyGFEnv :: GFEnv -emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0 - - -wordCompletion cmdEnv line prefix p = - case wc_type (take p line) of - CmplCmd pref - -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] - CmplStr (Just (Command _ opts _)) s - -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts))) - case mb_state0 of - Right state0 -> let ws = words (take (length s - length prefix) s) - state = foldl nextState state0 ws - compls = getCompletions state prefix - in ret ' ' (Map.keys compls) - Left _ -> ret ' ' [] - CmplOpt (Just (Command n _ _)) pref - -> case Map.lookup n (commands cmdEnv) of - Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg] - opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt] - ret (if null flg_compls then ' ' else '=') - (flg_compls++opt_compls) - Nothing -> ret ' ' [] - CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i - -> filenameCompletionFunction prefix - CmplIdent _ pref - -> do mb_abs <- try (evaluate (abstract pgf)) - case mb_abs of - Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name] - Left _ -> ret ' ' [] - _ -> ret ' ' [] - where - pgf = multigrammar cmdEnv - optLang opts = valIdOpts "lang" (head (languages pgf)) opts - optCat opts = valIdOpts "cat" (lookStartCat pgf) opts - - ret c [x] = return [x++[c]] - ret _ xs = return xs - - -data CompletionType - = CmplCmd Ident - | CmplStr (Maybe Command) String - | CmplOpt (Maybe Command) Ident - | CmplIdent (Maybe Command) Ident - deriving Show - -wc_type :: String -> CompletionType -wc_type = cmd_name - where - cmd_name cs = - let cs1 = dropWhile isSpace cs - in go cs1 cs1 - where - go x [] = CmplCmd x - go x (c:cs) - | isIdent c = go x cs - | otherwise = cmd x cs - - cmd x [] = ret CmplIdent x "" 0 - cmd _ ('|':cs) = cmd_name cs - cmd _ (';':cs) = cmd_name cs - cmd x ('"':cs) = str x cs cs - cmd x ('-':cs) = option x cs cs - cmd x (c :cs) - | isIdent c = ident x (c:cs) cs - | otherwise = cmd x cs - - option x y [] = ret CmplOpt x y 1 - option x y (c:cs) - | isIdent c = option x y cs - | otherwise = cmd x cs - - ident x y [] = ret CmplIdent x y 0 - ident x y (c:cs) - | isIdent c = ident x y cs - | otherwise = cmd x cs - - str x y [] = ret CmplStr x y 1 - str x y ('\"':cs) = cmd x cs - str x y ('\\':c:cs) = str x y cs - str x y (c:cs) = str x y cs - - ret f x y d = f cmd y - where - x1 = take (length x - length y - d) x - x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1 - - cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x - _ -> Nothing - - isIdent c = c == '_' || c == '\'' || isAlphaNum c +module GFI (mainGFI) where + +import GF.Command.Interpreter +import GF.Command.Importing +import GF.Command.Commands +import GF.Command.Abstract +import GF.Command.Parse +import GF.Data.ErrM +import GF.Grammar.API -- for cc command +import GF.Infra.UseIO +import GF.Infra.Option +import GF.System.Readline + +import PGF +import PGF.Data +import PGF.Macros +import PGF.Expr (readTree) + +import Data.Char +import Data.List(isPrefixOf) +import qualified Data.Map as Map +import qualified Text.ParserCombinators.ReadP as RP +import System.Cmd +import System.CPUTime +import Control.Exception + +import Data.Version +import Paths_gf + +mainGFI :: Options -> [FilePath] -> IO () +mainGFI opts files = do + putStrLn welcome + gfenv <- importInEnv emptyGFEnv opts files + loop opts gfenv + return () + +loop :: Options -> GFEnv -> IO GFEnv +loop opts gfenv0 = do + let env = commandenv gfenv0 + let sgr = sourcegrammar gfenv0 + setCompletionFunction (Just (wordCompletion (commandenv gfenv0))) + s <- fetchCommand (prompt env) + let gfenv = gfenv0 {history = s : history gfenv0} + let loopNewCPU gfenv' = do + cpu' <- getCPUTime + putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") + loop opts $ gfenv' {cputime = cpu'} + let + pwords = case words s of + w:ws -> getCommandOp w :ws + ws -> ws + case pwords of + -- special commands, requiring source grammar in env + "!":ws -> do + system $ unwords ws + loopNewCPU gfenv + "cc":ws -> do + let + (style,term) = case ws of + ('-':w):ws2 -> (pTermPrintStyle w, ws2) + _ -> (TermPrintDefault, ws) + case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- pipe! + Ok x -> putStrLn (showTerm style x) + Bad s -> putStrLn s + loopNewCPU gfenv + "i":args -> do + gfenv' <- case parseOptions args of + Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files + Bad err -> do putStrLn $ "Command parse error: " ++ err + return gfenv + loopNewCPU gfenv' + + -- other special commands, working on GFEnv + "e":_ -> loopNewCPU $ gfenv { + commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar + } + + "dc":f:ws -> do + case readCommandLine (unwords ws) of + Just comm -> loopNewCPU $ gfenv { + commandenv = env { + commandmacros = Map.insert f comm (commandmacros env) + } + } + _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv + + "dt":f:ws -> do + case readTree (unwords ws) of + Just exp -> loopNewCPU $ gfenv { + commandenv = env { + expmacros = Map.insert f exp (expmacros env) + } + } + _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv + + "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv + "q":_ -> putStrLn "See you." >> return gfenv + + -- ordinary commands, working on CommandEnv + _ -> do + interpretCommandLine env s + loopNewCPU gfenv + +importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv +importInEnv gfenv opts files + | flag optRetainResource opts = + do src <- importSource (sourcegrammar gfenv) opts files + return $ gfenv {sourcegrammar = src} + | otherwise = + do let opts' = addOptions (setOptimization OptCSE False) opts + pgf0 = multigrammar (commandenv gfenv) + pgf1 <- importGrammar pgf0 opts' files + putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 + return $ gfenv { commandenv = mkCommandEnv pgf1 } + +welcome = unlines [ + " ", + " * * * ", + " * * ", + " * * ", + " * ", + " * ", + " * * * * * * * ", + " * * * ", + " * * * * * * ", + " * * * ", + " * * * ", + " ", + "This is GF version "++showVersion version++". ", + "Some things may work. " + ] + +prompt env = absname ++ "> " where + absname = case abstractName (multigrammar env) of + "_" -> "" --- created by new Ident handling 22/5/2008 + n -> n + +data GFEnv = GFEnv { + sourcegrammar :: Grammar, -- gfo grammar -retain + commandenv :: CommandEnv, + history :: [String], + cputime :: Integer + } + +emptyGFEnv :: GFEnv +emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0 + + +wordCompletion cmdEnv line prefix p = + case wc_type (take p line) of + CmplCmd pref + -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] + CmplStr (Just (Command _ opts _)) s + -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts))) + case mb_state0 of + Right state0 -> let ws = words (take (length s - length prefix) s) + state = foldl nextState state0 ws + compls = getCompletions state prefix + in ret ' ' (Map.keys compls) + Left _ -> ret ' ' [] + CmplOpt (Just (Command n _ _)) pref + -> case Map.lookup n (commands cmdEnv) of + Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg] + opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt] + ret (if null flg_compls then ' ' else '=') + (flg_compls++opt_compls) + Nothing -> ret ' ' [] + CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i + -> filenameCompletionFunction prefix + CmplIdent _ pref + -> do mb_abs <- try (evaluate (abstract pgf)) + case mb_abs of + Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name] + Left _ -> ret ' ' [] + _ -> ret ' ' [] + where + pgf = multigrammar cmdEnv + optLang opts = valIdOpts "lang" (head (languages pgf)) opts + optCat opts = valIdOpts "cat" (lookStartCat pgf) opts + + ret c [x] = return [x++[c]] + ret _ xs = return xs + + +data CompletionType + = CmplCmd Ident + | CmplStr (Maybe Command) String + | CmplOpt (Maybe Command) Ident + | CmplIdent (Maybe Command) Ident + deriving Show + +wc_type :: String -> CompletionType +wc_type = cmd_name + where + cmd_name cs = + let cs1 = dropWhile isSpace cs + in go cs1 cs1 + where + go x [] = CmplCmd x + go x (c:cs) + | isIdent c = go x cs + | otherwise = cmd x cs + + cmd x [] = ret CmplIdent x "" 0 + cmd _ ('|':cs) = cmd_name cs + cmd _ (';':cs) = cmd_name cs + cmd x ('"':cs) = str x cs cs + cmd x ('-':cs) = option x cs cs + cmd x (c :cs) + | isIdent c = ident x (c:cs) cs + | otherwise = cmd x cs + + option x y [] = ret CmplOpt x y 1 + option x y (c:cs) + | isIdent c = option x y cs + | otherwise = cmd x cs + + ident x y [] = ret CmplIdent x y 0 + ident x y (c:cs) + | isIdent c = ident x y cs + | otherwise = cmd x cs + + str x y [] = ret CmplStr x y 1 + str x y ('\"':cs) = cmd x cs + str x y ('\\':c:cs) = str x y cs + str x y (c:cs) = str x y cs + + ret f x y d = f cmd y + where + x1 = take (length x - length y - d) x + x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1 + + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of + [x] -> Just x + _ -> Nothing + + isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src-3.0/PGF.hs b/src-3.0/PGF.hs index aa2fa2edf..0739815be 100644 --- a/src-3.0/PGF.hs +++ b/src-3.0/PGF.hs @@ -28,8 +28,13 @@ module PGF( Category, categories, startCat, -- * Expressions - Exp(..), Equation(..), - showExp, readExp, + -- ** Tree + Tree(..), + showTree, readTree, + + -- ** Expr + Expr(..), Equation(..), + showExpr, readExpr, -- * Operations -- ** Linearization @@ -38,6 +43,9 @@ module PGF( -- ** Parsing parse, parseAllLang, parseAll, + -- ** Evaluation + tree2expr, expr2tree, + -- ** Word Completion (Incremental Parsing) Incremental.ParseState, initState, Incremental.nextState, Incremental.getCompletions, extractExps, @@ -52,7 +60,7 @@ import qualified PGF.Linearize (linearize) import PGF.Generate import PGF.Macros import PGF.Data -import PGF.ExprSyntax +import PGF.Expr import PGF.Raw.Convert import PGF.Raw.Parse import PGF.Raw.Print (printTree) @@ -90,25 +98,25 @@ type Category = String readPGF :: FilePath -> IO PGF -- | Linearizes given expression as string in the language -linearize :: PGF -> Language -> Exp -> String +linearize :: PGF -> Language -> Tree -> String -- | Tries to parse the given string in the specified language -- and to produce abstract syntax expression. An empty -- list is returned if the parsing is not successful. The list may also -- contain more than one element if the grammar is ambiguous. -parse :: PGF -> Language -> Category -> String -> [Exp] +parse :: PGF -> Language -> Category -> String -> [Tree] -- | The same as 'linearizeAllLang' but does not return -- the language. -linearizeAll :: PGF -> Exp -> [String] +linearizeAll :: PGF -> Tree -> [String] -- | Linearizes given expression as string in all languages -- available in the grammar. -linearizeAllLang :: PGF -> Exp -> [(Language,String)] +linearizeAllLang :: PGF -> Tree -> [(Language,String)] -- | The same as 'parseAllLang' but does not return -- the language. -parseAll :: PGF -> Category -> String -> [[Exp]] +parseAll :: PGF -> Category -> String -> [[Tree]] -- | Tries to parse the given string with every language -- available in the grammar and to produce abstract syntax @@ -117,7 +125,7 @@ parseAll :: PGF -> Category -> String -> [[Exp]] -- for which at least one parsing is possible are listed. -- More than one abstract syntax expressions are possible -- if the grammar is ambiguous. -parseAllLang :: PGF -> Category -> String -> [(Language,[Exp])] +parseAllLang :: PGF -> Category -> String -> [(Language,[Tree])] -- | Creates an initial parsing state for a given language and -- startup category. @@ -127,21 +135,21 @@ initState :: PGF -> Language -> Category -> Incremental.ParseState -- that spans the whole input consumed so far. The trees are also -- limited by the category specified, which is usually -- the same as the startup category. -extractExps :: Incremental.ParseState -> Category -> [Exp] +extractExps :: Incremental.ParseState -> Category -> [Tree] -- | The same as 'generateAllDepth' but does not limit -- the depth in the generation. -generateAll :: PGF -> Category -> [Exp] +generateAll :: PGF -> Category -> [Tree] -- | Generates an infinite list of random abstract syntax expressions. -- This is usefull for tree bank generation which after that can be used -- for grammar testing. -generateRandom :: PGF -> Category -> IO [Exp] +generateRandom :: PGF -> Category -> IO [Tree] -- | Generates an exhaustive possibly infinite list of -- abstract syntax expressions. A depth can be specified -- to limit the search space. -generateAllDepth :: PGF -> Category -> Maybe Int -> [Exp] +generateAllDepth :: PGF -> Category -> Maybe Int -> [Tree] -- | List of all languages available in the given grammar. languages :: PGF -> [Language] diff --git a/src-3.0/PGF/Data.hs b/src-3.0/PGF/Data.hs index 896e821db..06013924c 100644 --- a/src-3.0/PGF/Data.hs +++ b/src-3.0/PGF/Data.hs @@ -21,10 +21,10 @@ data PGF = PGF { } data Abstr = Abstr { - aflags :: Map.Map CId String, -- value of a flag - funs :: Map.Map CId (Type,Exp), -- type and def of a fun - cats :: Map.Map CId [Hypo], -- context of a cat - catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) + aflags :: Map.Map CId String, -- value of a flag + funs :: Map.Map CId (Type,Expr), -- type and def of a fun + cats :: Map.Map CId [Hypo], -- context of a cat + catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) } data Concr = Concr { @@ -39,20 +39,40 @@ data Concr = Concr { } data Type = - DTyp [Hypo] CId [Exp] + DTyp [Hypo] CId [Expr] deriving (Eq,Ord,Show) --- | An expression representing the abstract syntax tree --- in PGF. The same expression is used in the dependent --- types. -data Exp = - EAbs [CId] Exp -- ^ lambda abstraction. The list should contain at least one variable - | EApp CId [Exp] -- ^ application. Note that unevaluated lambda abstractions are not allowed - | EStr String -- ^ string constant - | EInt Integer -- ^ integer constant - | EFloat Double -- ^ floating point constant +data Literal = + LStr String -- ^ string constant + | LInt Integer -- ^ integer constant + | LFlt Double -- ^ floating point constant + deriving (Eq,Ord,Show) + +-- | The tree is an evaluated expression in the abstract syntax +-- of the grammar. The type is especially restricted to not +-- allow unapplied lambda abstractions. The meta variables +-- also does not have indices because both the parser and +-- the linearizer consider all meta variable occurrences as +-- distinct. The tree is used directly from the linearizer +-- and is produced directly from the parser. +data Tree = + Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty + | Var CId -- ^ variable + | Fun CId [Tree] -- ^ function application + | Lit Literal -- ^ literal + | Meta Int -- ^ meta variable. Each occurency of 'Meta' means a different metavariable + deriving (Show, Eq, Ord) + +-- | An expression represents a potentially unevaluated expression +-- in the abstract syntax of the grammar. It can be evaluated with +-- the 'expr2tree' function and then linearized or it can be used +-- directly in the dependent types. +data Expr = + EAbs CId Expr -- ^ lambda abstraction + | EApp Expr Expr -- ^ application + | ELit Literal -- ^ literal | EMeta Int -- ^ meta variable - | EVar CId -- ^ variable reference + | EVar CId -- ^ variable or function reference | EEq [Equation] -- ^ lambda function defined as a set of equations with pattern matching deriving (Eq,Ord,Show) @@ -71,11 +91,11 @@ data Term = data Tokn = KS String - | KP [String] [Variant] + | KP [String] [Alternative] deriving (Eq,Ord,Show) -data Variant = - Var [String] [String] +data Alternative = + Alt [String] [String] deriving (Eq,Ord,Show) data Hypo = @@ -83,11 +103,11 @@ data Hypo = deriving (Eq,Ord,Show) -- | The equation is used to define lambda function as a sequence --- of equations with pattern matching. The list of 'Exp' represents --- the patterns and the second 'Exp' is the function body for this +-- of equations with pattern matching. The list of 'Expr' represents +-- the patterns and the second 'Expr' is the function body for this -- equation. data Equation = - Equ [Exp] Exp + Equ [Expr] Expr deriving (Eq,Ord,Show) diff --git a/src-3.0/PGF/Expr.hs b/src-3.0/PGF/Expr.hs new file mode 100644 index 000000000..332fbc657 --- /dev/null +++ b/src-3.0/PGF/Expr.hs @@ -0,0 +1,202 @@ +module PGF.Expr(readTree, showTree, pTree, ppTree, + readExpr, showExpr, pExpr, ppExpr, + + tree2expr, expr2tree, + + -- needed in the typechecker + Value(..), Env, eval, + + -- helpers + pIdent,pStr + ) where + +import PGF.CId +import PGF.Data + +import Data.Char +import Data.Maybe +import Control.Monad +import qualified Text.PrettyPrint as PP +import qualified Text.ParserCombinators.ReadP as RP +import qualified Data.Map as Map + + +-- | parses 'String' as an expression +readTree :: String -> Maybe Tree +readTree s = case [x | (x,cs) <- RP.readP_to_S (pTree False) s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | renders expression as 'String' +showTree :: Tree -> String +showTree = PP.render . ppTree 0 + +-- | parses 'String' as an expression +readExpr :: String -> Maybe Expr +readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | renders expression as 'String' +showExpr :: Expr -> String +showExpr = PP.render . ppExpr 0 + + +----------------------------------------------------- +-- Parsing +----------------------------------------------------- + +pTrees :: RP.ReadP [Tree] +pTrees = liftM2 (:) (pTree True) pTrees RP.<++ (RP.skipSpaces >> return []) + +pTree :: Bool -> RP.ReadP Tree +pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Lit pLit RP.<++ pMeta) + where + pParen = RP.between (RP.char '(') (RP.char ')') (pTree False) + pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ',')) + t <- pTree False + return (Abs xs t) + pApp = do f <- pCId + ts <- (if isNested then return [] else pTrees) + return (Fun f ts) + pMeta = do RP.char '?' + n <- fmap read (RP.munch1 isDigit) + return (Meta n) + +pExpr :: RP.ReadP Expr +pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm RP.<++ pEqs) + where + pTerm = fmap (foldl1 EApp) (RP.sepBy1 pFactor RP.skipSpaces) + + pFactor = fmap EVar pCId + RP.<++ fmap ELit pLit + RP.<++ pMeta + RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr + + pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ',')) + e <- pExpr + return (foldr EAbs e xs) + + pMeta = do RP.char '?' + n <- fmap read (RP.munch1 isDigit) + return (EMeta n) + + pEqs = fmap EEq $ + RP.between (RP.skipSpaces >> RP.char '{') + (RP.skipSpaces >> RP.char '}') + (RP.sepBy1 (RP.skipSpaces >> pEq) + (RP.skipSpaces >> RP.string ";")) + + pEq = do pats <- (RP.sepBy1 pExpr RP.skipSpaces) + RP.skipSpaces >> RP.string "=>" + e <- pExpr + return (Equ pats e) + +pLit :: RP.ReadP Literal +pLit = pNum RP.<++ liftM LStr pStr + +pNum = do x <- RP.munch1 isDigit + ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (LFlt (read (x++"."++y)))) + RP.<++ + (return (LInt (read x)))) + +pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) + where + pEsc = RP.char '\\' >> RP.get + +pCId = fmap mkCId pIdent + +pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) + where + isIdentFirst c = c == '_' || isLetter c + isIdentRest c = c == '_' || c == '\'' || isAlphaNum c + + +----------------------------------------------------- +-- Printing +----------------------------------------------------- + +ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<> + PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+> + PP.text "->" PP.<+> + ppTree 0 t) +ppTree d (Fun f []) = PP.text (prCId f) +ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (map (ppTree 1) ts)) +ppTree d (Lit l) = ppLit l +ppTree d (Meta n) = PP.char '?' PP.<> PP.int n +ppTree d (Var id) = PP.text (prCId id) + + +ppExpr d (EAbs x e) = let (xs,e1) = getVars (EAbs x e) + in ppParens (d > 0) (PP.char '\\' PP.<> + PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+> + PP.text "->" PP.<+> + ppExpr 0 e1) + where + getVars (EAbs x e) = let (xs,e1) = getVars e in (x:xs,e1) + getVars e = ([],e) +ppExpr d (EApp e1 e2) = ppParens (d > 1) ((ppExpr 1 e1) PP.<+> (ppExpr 2 e2)) +ppExpr d (ELit l) = ppLit l +ppExpr d (EMeta n) = PP.char '?' PP.<+> PP.int n +ppExpr d (EVar f) = PP.text (prCId f) +ppExpr d (EEq eqs) = PP.braces (PP.sep (PP.punctuate PP.semi (map ppEquation eqs))) + +ppEquation (Equ pats e) = PP.hsep (map (ppExpr 2) pats) PP.<+> PP.text "=>" PP.<+> ppExpr 0 e + +ppLit (LStr s) = PP.text (show s) +ppLit (LInt n) = PP.integer n +ppLit (LFlt d) = PP.double d + +ppParens True = PP.parens +ppParens False = id + + +----------------------------------------------------- +-- Evaluation +----------------------------------------------------- + +-- | Converts a tree to expression. +tree2expr :: Tree -> Expr +tree2expr (Fun x ts) = foldl EApp (EVar x) (map tree2expr ts) +tree2expr (Lit l) = ELit l +tree2expr (Meta n) = EMeta n +tree2expr (Abs xs t) = foldr EAbs (tree2expr t) xs +tree2expr (Var x) = EVar x + +-- | Converts an expression to tree. If the expression +-- contains unevaluated applications they will be applied. +expr2tree e = value2tree (eval Map.empty e) [] [] + where + value2tree (VApp v1 v2) xs ts = value2tree v1 xs (value2tree v2 [] []:ts) + value2tree (VVar x) xs ts = ret xs (fun xs x ts) + value2tree (VMeta n) xs [] = ret xs (Meta n) + value2tree (VLit l) xs [] = ret xs (Lit l) + value2tree (VClosure env (EAbs x e)) xs [] = value2tree (eval (Map.insert x (VVar x) env) e) (x:xs) [] + + fun xs x ts + | x `elem` xs = Var x + | otherwise = Fun x ts + + ret [] t = t + ret xs t = Abs (reverse xs) t + +data Value + = VGen Int + | VApp Value Value + | VVar CId + | VMeta Int + | VLit Literal + | VClosure Env Expr + +type Env = Map.Map CId Value + +eval :: Env -> Expr -> Value +eval env (EVar x) = fromMaybe (VVar x) (Map.lookup x env) +eval env (EApp e1 e2) = apply (eval env e1) (eval env e2) +eval env (EAbs x e) = VClosure env (EAbs x e) +eval env (EMeta k) = VMeta k +eval env (ELit l) = VLit l + +apply :: Value -> Value -> Value +apply (VClosure env (EAbs x e)) v = eval (Map.insert x v env) e +apply v0 v = VApp v0 v diff --git a/src-3.0/PGF/ExprSyntax.hs b/src-3.0/PGF/ExprSyntax.hs deleted file mode 100644 index ee4be36ea..000000000 --- a/src-3.0/PGF/ExprSyntax.hs +++ /dev/null @@ -1,73 +0,0 @@ -module PGF.ExprSyntax(readExp, showExp, - pExp,ppExp, - - -- helpers - pIdent,pStr - ) where - -import PGF.CId -import PGF.Data - -import Data.Char -import Control.Monad -import qualified Text.PrettyPrint as PP -import qualified Text.ParserCombinators.ReadP as RP - - --- | parses 'String' as an expression -readExp :: String -> Maybe Exp -readExp s = case [x | (x,cs) <- RP.readP_to_S (pExp False) s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - --- | renders expression as 'String' -showExp :: Exp -> String -showExp = PP.render . ppExp False - -pExps :: RP.ReadP [Exp] -pExps = liftM2 (:) (pExp True) pExps RP.<++ (RP.skipSpaces >> return []) - -pExp :: Bool -> RP.ReadP Exp -pExp isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ pNum RP.<++ - liftM EStr pStr RP.<++ pMeta) - where - pParen = RP.between (RP.char '(') (RP.char ')') (pExp False) - pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ',')) - t <- pExp False - return (EAbs xs t) - pApp = do f <- pCId - ts <- (if isNested then return [] else pExps) - return (EApp f ts) - pMeta = do RP.char '?' - x <- RP.munch1 isDigit - return (EMeta (read x)) - pNum = do x <- RP.munch1 isDigit - ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (EFloat (read (x++"."++y)))) - RP.<++ - (return (EInt (read x)))) - -pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) - where - pEsc = RP.char '\\' >> RP.get - -pCId = fmap mkCId pIdent - -pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) - where - isIdentFirst c = c == '_' || isLetter c - isIdentRest c = c == '_' || c == '\'' || isAlphaNum c - -ppExp isNested (EAbs xs t) = ppParens isNested (PP.char '\\' PP.<> - PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+> - PP.text "->" PP.<+> - ppExp False t) -ppExp isNested (EApp f []) = PP.text (prCId f) -ppExp isNested (EApp f ts) = ppParens isNested (PP.text (prCId f) PP.<+> PP.hsep (map (ppExp True) ts)) -ppExp isNested (EStr s) = PP.text (show s) -ppExp isNested (EInt n) = PP.integer n -ppExp isNested (EFloat d) = PP.double d -ppExp isNested (EMeta n) = PP.char '?' PP.<> PP.int n -ppExp isNested (EVar id) = PP.text (prCId id) - -ppParens True = PP.parens -ppParens False = id diff --git a/src-3.0/PGF/Generate.hs b/src-3.0/PGF/Generate.hs index 4c369c6d0..64ca4d5f5 100644 --- a/src-3.0/PGF/Generate.hs +++ b/src-3.0/PGF/Generate.hs @@ -8,23 +8,23 @@ import qualified Data.Map as M import System.Random -- generate an infinite list of trees exhaustively -generate :: PGF -> CId -> Maybe Int -> [Exp] +generate :: PGF -> CId -> Maybe Int -> [Tree] generate pgf cat dp = concatMap (\i -> gener i cat) depths where - gener 0 c = [EApp f [] | (f, ([],_)) <- fns c] + gener 0 c = [Fun f [] | (f, ([],_)) <- fns c] gener i c = [ tr | (f, (cs,_)) <- fns c, let alts = map (gener (i-1)) cs, ts <- combinations alts, - let tr = EApp f ts, + let tr = Fun f ts, depth tr >= i ] fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c] depths = maybe [0 ..] (\d -> [0..d]) dp -- generate an infinite list of trees randomly -genRandom :: StdGen -> PGF -> CId -> [Exp] +genRandom :: StdGen -> PGF -> CId -> [Tree] genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where timeout = 47 -- give up @@ -36,16 +36,16 @@ genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where (genTrees ds2 cat) -- else (drop k ds) genTree rs = gett rs where - gett ds cid | cid == mkCId "String" = (EStr "foo", 1) - gett ds cid | cid == mkCId "Int" = (EInt 12345, 1) - gett [] _ = (EStr "TIMEOUT", 1) ---- + gett ds cid | cid == mkCId "String" = (Lit (LStr "foo"), 1) + gett ds cid | cid == mkCId "Int" = (Lit (LInt 12345), 1) + gett [] _ = (Lit (LStr "TIMEOUT"), 1) ---- gett ds cat = case fns cat of - [] -> (EMeta 0,1) + [] -> (Meta 0,1) fs -> let d:ds2 = ds (f,args) = getf d fs (ts,k) = getts ds2 args - in (EApp f ts, k+1) + in (Fun f ts, k+1) getf d fs = let lg = (length fs) in fs !! (floor (d * fromIntegral lg)) getts ds cats = case cats of diff --git a/src-3.0/PGF/Linearize.hs b/src-3.0/PGF/Linearize.hs index 2d23e8653..c3341698f 100644 --- a/src-3.0/PGF/Linearize.hs +++ b/src-3.0/PGF/Linearize.hs @@ -10,8 +10,8 @@ import Debug.Trace -- linearization and computation of concrete PGF Terms -linearize :: PGF -> CId -> Exp -> String -linearize pgf lang = realize . linExp pgf lang +linearize :: PGF -> CId -> Tree -> String +linearize pgf lang = realize . linTree pgf lang realize :: Term -> String realize trm = case trm of @@ -25,18 +25,18 @@ realize trm = case trm of TM s -> s _ -> "ERROR " ++ show trm ---- debug -linExp :: PGF -> CId -> Exp -> Term -linExp pgf lang = lin +linTree :: PGF -> CId -> Tree -> Term +linTree pgf lang = lin where - lin (EAbs xs e ) = case lin e of - R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) - TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs) - lin (EApp fun es) = comp (map lin es) $ look fun - lin (EStr s ) = R [kks (show s)] -- quoted - lin (EInt i ) = R [kks (show i)] - lin (EFloat d ) = R [kks (show d)] - lin (EVar x ) = TM (prCId x) - lin (EMeta i ) = TM (show i) + lin (Abs xs e ) = case lin e of + R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) + TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs) + lin (Fun fun es) = comp (map lin es) $ look fun + lin (Lit (LStr s)) = R [kks (show s)] -- quoted + lin (Lit (LInt i)) = R [kks (show i)] + lin (Lit (LFlt d)) = R [kks (show d)] + lin (Var x) = TM (prCId x) + lin (Meta i) = TM (show i) comp = compute pgf lang look = lookLin pgf lang diff --git a/src-3.0/PGF/Macros.hs b/src-3.0/PGF/Macros.hs index baa0fc355..a680cf0f9 100644 --- a/src-3.0/PGF/Macros.hs +++ b/src-3.0/PGF/Macros.hs @@ -87,10 +87,10 @@ restrictPGF cond pgf = pgf { restrict = Map.filterWithKey (\c _ -> cond c) abstr = abstract pgf -depth :: Exp -> Int -depth (EAbs _ t) = depth t -depth (EApp _ ts) = maximum (0:map depth ts) + 1 -depth _ = 1 +depth :: Tree -> Int +depth (Abs _ t) = depth t +depth (Fun _ ts) = maximum (0:map depth ts) + 1 +depth _ = 1 cftype :: [CId] -> CId -> Type cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val [] @@ -111,7 +111,7 @@ contextLength :: Type -> Int contextLength ty = case ty of DTyp hyps _ _ -> length hyps -primNotion :: Exp +primNotion :: Expr primNotion = EEq [] term0 :: CId -> Term diff --git a/src-3.0/PGF/Parsing/FCFG.hs b/src-3.0/PGF/Parsing/FCFG.hs index abf90c83f..4ca6a956a 100644 --- a/src-3.0/PGF/Parsing/FCFG.hs +++ b/src-3.0/PGF/Parsing/FCFG.hs @@ -29,11 +29,11 @@ import qualified Data.Map as Map -- main parsing function -parseFCFG :: String -- ^ parsing strategy +parseFCFG :: String -- ^ parsing strategy -> ParserInfo -- ^ compiled grammar (fcfg) -> CId -- ^ starting category -> [String] -- ^ input tokens - -> Err [Exp] -- ^ resulting GF terms + -> Err [Tree] -- ^ resulting GF terms parseFCFG "bottomup" pinfo start toks = return $ Active.parse "b" pinfo start toks parseFCFG "topdown" pinfo start toks = return $ Active.parse "t" pinfo start toks parseFCFG "incremental" pinfo start toks = return $ Incremental.parse pinfo start toks diff --git a/src-3.0/PGF/Parsing/FCFG/Active.hs b/src-3.0/PGF/Parsing/FCFG/Active.hs index 80cfccdee..4386bfdd1 100644 --- a/src-3.0/PGF/Parsing/FCFG/Active.hs +++ b/src-3.0/PGF/Parsing/FCFG/Active.hs @@ -32,8 +32,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange]) makeFinalEdge cat i j = (cat, [makeRange i j]) -- | the list of categories = possible starting categories -parse :: String -> ParserInfo -> CId -> [FToken] -> [Exp] -parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2exps +parse :: String -> ParserInfo -> CId -> [FToken] -> [Tree] +parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees where inTokens = input toks starts = Map.findWithDefault [] start (startupCats pinfo) diff --git a/src-3.0/PGF/Parsing/FCFG/Incremental.hs b/src-3.0/PGF/Parsing/FCFG/Incremental.hs index 16a5e8875..fff5f0212 100644 --- a/src-3.0/PGF/Parsing/FCFG/Incremental.hs +++ b/src-3.0/PGF/Parsing/FCFG/Incremental.hs @@ -25,7 +25,7 @@ import PGF.Data import PGF.Parsing.FCFG.Utilities import Debug.Trace -parse :: ParserInfo -> CId -> [FToken] -> [Exp] +parse :: ParserInfo -> CId -> [FToken] -> [Tree] parse pinfo start toks = extractExps (foldl' nextState (initState pinfo start) toks) start initState :: ParserInfo -> CId -> ParseState @@ -82,7 +82,7 @@ getCompletions (State pinfo chart items) w = | isPrefixOf w tok = fromMaybe map (MM.insert' tok item map) | otherwise = map -extractExps :: ParseState -> CId -> [Exp] +extractExps :: ParseState -> CId -> [Tree] extractExps (State pinfo chart items) start = exps where (_,st) = process (\_ _ -> id) (allRules pinfo) (Set.toList items) ((),chart) @@ -103,7 +103,7 @@ extractExps (State pinfo chart items) start = exps if fn == wildCId then go (Set.insert fid rec) (head args) else do args <- mapM (go (Set.insert fid rec)) args - return (EApp fn args) + return (Fun fn args) process fn !rules [] acc_chart = acc_chart process fn !rules (item:items) acc_chart = univRule item acc_chart diff --git a/src-3.0/PGF/Parsing/FCFG/Utilities.hs b/src-3.0/PGF/Parsing/FCFG/Utilities.hs index e435c6154..4187d0f24 100644 --- a/src-3.0/PGF/Parsing/FCFG/Utilities.hs +++ b/src-3.0/PGF/Parsing/FCFG/Utilities.hs @@ -179,9 +179,9 @@ applyProfileToForest (FFloat f) = [FFloat f] applyProfileToForest (FMeta) = [FMeta] -forest2exps :: SyntaxForest CId -> [Exp] -forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps -forest2exps (FString s) = [EStr s] -forest2exps (FInt n) = [EInt n] -forest2exps (FFloat f) = [EFloat f] -forest2exps (FMeta) = [EMeta 0] +forest2trees :: SyntaxForest CId -> [Tree] +forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees +forest2trees (FString s) = [Lit (LStr s)] +forest2trees (FInt n) = [Lit (LInt n)] +forest2trees (FFloat f) = [Lit (LFlt f)] +forest2trees (FMeta) = [Meta 0] diff --git a/src-3.0/PGF/Raw/Convert.hs b/src-3.0/PGF/Raw/Convert.hs index a8398093b..af3708eb5 100644 --- a/src-3.0/PGF/Raw/Convert.hs +++ b/src-3.0/PGF/Raw/Convert.hs @@ -105,16 +105,16 @@ toHypo e = case e of App x [typ] -> Hyp (mkCId x) (toType typ) _ -> error $ "hypo " ++ show e -toExp :: RExp -> Exp +toExp :: RExp -> Expr toExp e = case e of - App "Abs" [App "B" xs, exp] -> EAbs [mkCId x | App x [] <- xs] (toExp exp) - App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps) + App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp) + App "App" [e1,e2] -> EApp (toExp e1) (toExp e2) App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs] App "Var" [App i []] -> EVar (mkCId i) AMet -> EMeta 0 - AInt i -> EInt i - AFlt i -> EFloat i - AStr i -> EStr i + AInt i -> ELit (LInt i) + AFlt i -> ELit (LFlt i) + AStr i -> ELit (LStr i) _ -> error $ "exp " ++ show e toTerm :: RExp -> Term @@ -170,14 +170,14 @@ fromHypo :: Hypo -> RExp fromHypo e = case e of Hyp x typ -> App (prCId x) [fromType typ] -fromExp :: Exp -> RExp +fromExp :: Expr -> RExp fromExp e = case e of - EAbs xs exp -> App "Abs" [App "B" (map (flip App [] . prCId) xs), fromExp exp] - EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps) + EAbs x exp -> App "Abs" [App (prCId x) [], fromExp exp] + EApp e1 e2 -> App "App" [fromExp e1, fromExp e2] EVar x -> App "Var" [App (prCId x) []] - EStr s -> AStr s - EFloat d -> AFlt d - EInt i -> AInt (toInteger i) + ELit (LStr s) -> AStr s + ELit (LFlt d) -> AFlt d + ELit (LInt i) -> AInt (toInteger i) EMeta _ -> AMet ---- EEq eqs -> App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs] @@ -194,7 +194,7 @@ fromTerm e = case e of F f -> App (prCId f) [] V i -> App "A" [AInt (toInteger i)] K (KS s) -> AStr s ---- - K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ---- + K (KP d vs) -> App "FV" (str d : [str v | Alt v _ <- vs]) ---- where str v = App "S" (map AStr v) diff --git a/src-3.0/PGF/ShowLinearize.hs b/src-3.0/PGF/ShowLinearize.hs index 8c01c3ddd..ae1385d98 100644 --- a/src-3.0/PGF/ShowLinearize.hs +++ b/src-3.0/PGF/ShowLinearize.hs @@ -53,17 +53,17 @@ mkRecord typ trm = case (typ,trm) of str = realize -- show all branches, without labels and params -allLinearize :: PGF -> CId -> Exp -> String +allLinearize :: PGF -> CId -> Tree -> String allLinearize pgf lang = concat . map pr . tabularLinearize pgf lang where pr (p,vs) = unlines vs -- show all branches, with labels and params -tableLinearize :: PGF -> CId -> Exp -> String +tableLinearize :: PGF -> CId -> Tree -> String tableLinearize pgf lang = unlines . map pr . tabularLinearize pgf lang where pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" vs) -- create a table from labels+params to variants -tabularLinearize :: PGF -> CId -> Exp -> [(String,[String])] +tabularLinearize :: PGF -> CId -> Tree -> [(String,[String])] tabularLinearize pgf lang = branches . recLinearize pgf lang where branches r = case r of RR fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t] @@ -73,18 +73,18 @@ tabularLinearize pgf lang = branches . recLinearize pgf lang where RCon _ -> [] -- show record in GF-source-like syntax -recordLinearize :: PGF -> CId -> Exp -> String +recordLinearize :: PGF -> CId -> Tree -> String recordLinearize pgf lang = prRecord . recLinearize pgf lang -- create a GF-like record, forming the basis of all functions above -recLinearize :: PGF -> CId -> Exp -> Record -recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where - typ = case exp of - EApp f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f +recLinearize :: PGF -> CId -> Tree -> Record +recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where + typ = case tree of + Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f -- show PGF term -termLinearize :: PGF -> CId -> Exp -> String -termLinearize pgf lang = show . linExp pgf lang +termLinearize :: PGF -> CId -> Tree -> String +termLinearize pgf lang = show . linTree pgf lang -- for Morphology: word, lemma, tags @@ -94,7 +94,7 @@ collectWords pgf lang = [(f,c,0) | (f,(DTyp [] c _,_)) <- Map.toList $ funs $ abstract pgf] where collOne (f,c,i) = - fromRec f [prCId c] (recLinearize pgf lang (EApp f (replicate i (EMeta 888)))) + fromRec f [prCId c] (recLinearize pgf lang (Fun f (replicate i (Meta 888)))) fromRec f v r = case r of RR rs -> concat [fromRec f v t | (_,t) <- rs] RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]