split the Exp type to Tree and Expr

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

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)

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))
+   fromTrees ts = (ts,unlines (map showTree ts))
-   fromStrings ss = (map EStr ss, unlines ss)
+   fromStrings ss = (map (Lit . LStr) ss, unlines ss)
-   fromString  s  = ([EStr s], s)
+   fromString  s  = ([Lit (LStr s)], s)
-   toStrings ts = [s | EStr s <- ts] 
+   toStrings ts = [s | Lit (LStr s) <- ts] 
-   toString ts = unwords [s | EStr s <- ts] 
+   toString ts = unwords [s | Lit (LStr s) <- ts] 
 
    prGrammar opts = case opts of
      _ | isOpt "cats" opts -> unwords $ categories pgf

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))
+  ATree e -> Command i os (ATree (app e))
-  _ -> c
+  _       -> c
  where
   app e = case e of
-    EMeta i -> xs !! i
+    Meta i   -> xs !! i
-    EApp f as -> EApp f (map app as)
+    Fun f as -> Fun f (map app as)
-    EAbs x b  -> EAbs x (app b)
+    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
+  ATree t -> [t] -- ignore piped
-  ANoArg -> ts  -- use piped
+  ANoArg  -> ts  -- use piped
 
 -- abbreviation convention from gf commands
 getCommandOp s = case break (=='_') s of

src-3.0/GF/Command/Parse.hs

@@ -1,7 +1,7 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF.ExprSyntax
+import PGF.Expr
-import PGF.Data(Exp)
+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))

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)])

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

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

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 = foldr (C.EAbs . i2i) t xs
-    mkAbs xs t = C.EAbs [i2i x | x <- xs] t
+    mkApp c args = case c of
-    mkApp c args = case c of 
+      Q _ c    -> foldl C.EApp (C.EVar (i2i c)) args
-      Q _ c    -> C.EApp (i2i c) args
+      QC _ c   -> foldl C.EApp (C.EVar (i2i c)) args
-      QC _ c   -> C.EApp (i2i c) args
       Vr x     -> C.EVar (i2i x)
-      EInt i   -> C.EInt   i
+      EInt i   -> C.ELit (C.LInt i)
-      EFloat f -> C.EFloat f
+      EFloat f -> C.ELit (C.LFlt f)
-      K s      -> C.EStr   s
+      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

src-3.0/GFI.hs

@@ -1,257 +1,237 @@
-module GFI (mainGFI) where
+module GFI (mainGFI) where
-
+
-import GF.Command.Interpreter
+import GF.Command.Interpreter
-import GF.Command.Importing
+import GF.Command.Importing
-import GF.Command.Commands
+import GF.Command.Commands
-import GF.Command.Abstract
+import GF.Command.Abstract
-import GF.Command.Parse
+import GF.Command.Parse
-import GF.Data.ErrM
+import GF.Data.ErrM
-import GF.Grammar.API  -- for cc command
+import GF.Grammar.API  -- for cc command
-import GF.Infra.UseIO
+import GF.Infra.UseIO
-import GF.Infra.Option
+import GF.Infra.Option
-import GF.System.Readline
+import GF.System.Readline
-
+
-import PGF
+import PGF
-import PGF.Data
+import PGF.Data
-import PGF.Macros
+import PGF.Macros
-import PGF.ExprSyntax (readExp)
+import PGF.Expr (readTree)
-
+
-import Data.Char
+import Data.Char
-import Data.List(isPrefixOf)
+import Data.List(isPrefixOf)
-import qualified Data.Map as Map
+import qualified Data.Map as Map
-import qualified Text.ParserCombinators.ReadP as RP
+import qualified Text.ParserCombinators.ReadP as RP
-import System.Cmd
+import System.Cmd
-import System.CPUTime
+import System.CPUTime
-import Control.Exception
+import Control.Exception
-
+
-import Data.Version
+import Data.Version
-import Paths_gf
+import Paths_gf
-
+
-mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI :: Options -> [FilePath] -> IO ()
-mainGFI opts files = do
+mainGFI opts files = do
-  putStrLn welcome
+  putStrLn welcome
-  gfenv <- importInEnv emptyGFEnv opts files
+  gfenv <- importInEnv emptyGFEnv opts files
-  loop opts gfenv
+  loop opts gfenv
-  return ()
+  return ()
-
+
-loop :: Options -> GFEnv -> IO GFEnv
+loop :: Options -> GFEnv -> IO GFEnv
-loop opts gfenv0 = do
+loop opts gfenv0 = do
-  let env = commandenv gfenv0
+  let env = commandenv gfenv0
-  let sgr = sourcegrammar gfenv0
+  let sgr = sourcegrammar gfenv0
-  setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
+  setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
-  s <- fetchCommand (prompt env)
+  s <- fetchCommand (prompt env)
-  let gfenv = gfenv0 {history = s : history gfenv0}
+  let gfenv = gfenv0 {history = s : history gfenv0}
-  let loopNewCPU gfenv' = do 
+  let loopNewCPU gfenv' = do 
-        cpu' <- getCPUTime
+        cpu' <- getCPUTime
-        putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
+        putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
-        loop opts $ gfenv' {cputime = cpu'}
+        loop opts $ gfenv' {cputime = cpu'}
-  let 
+  let 
-    pwords = case words s of
+    pwords = case words s of
-      w:ws -> getCommandOp w :ws
+      w:ws -> getCommandOp w :ws
-      ws -> ws
+      ws -> ws
-  case pwords of
+  case pwords of
-  -- special commands, requiring source grammar in env
+  -- special commands, requiring source grammar in env
-    "!":ws -> do
+    "!":ws -> do
-       system $ unwords ws
+       system $ unwords ws
-       loopNewCPU gfenv
+       loopNewCPU gfenv
-    "cc":ws -> do
+    "cc":ws -> do
-       let 
+       let 
-         (style,term) = case ws of 
+         (style,term) = case ws of 
-           ('-':w):ws2 -> (pTermPrintStyle w, ws2)
+           ('-':w):ws2 -> (pTermPrintStyle w, ws2)
-           _ -> (TermPrintDefault, ws)
+           _ -> (TermPrintDefault, ws)
-       case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of   ---- pipe!
+       case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of   ---- pipe!
-         Ok  x -> putStrLnFlush (showTerm style x)
+         Ok  x -> putStrLn (showTerm style x)
-         Bad s -> putStrLnFlush s
+         Bad s -> putStrLn s
-       loopNewCPU gfenv
+       loopNewCPU gfenv
-    "i":args -> do
+    "i":args -> do
-        gfenv' <- case parseOptions args of
+        gfenv' <- case parseOptions args of
-          Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
+                    Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
-          Bad err -> do 
+                    Bad err -> do putStrLn $ "Command parse error: " ++ err
-            putStrLn $ "Command parse error: " ++ err
+                                  return gfenv
-            return gfenv
+        loopNewCPU gfenv'
-        loopNewCPU gfenv'
+
-
+  -- other special commands, working on GFEnv
-  -- other special commands, working on GFEnv
+    "e":_ -> loopNewCPU $ gfenv {
-    "e":_ -> loopNewCPU $ gfenv {
+       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
-       commandenv=emptyCommandEnv, sourcegrammar = emptyGrammar
+       }
-       }
+
-
+    "dc":f:ws -> do
-    "dc":f:ws -> do
+       case readCommandLine (unwords ws) of
-       case readCommandLine (unwords ws) of
+         Just comm -> loopNewCPU $ gfenv {
-         Just comm -> loopNewCPU $ gfenv {
+           commandenv = env {
-           commandenv = env {
+             commandmacros = Map.insert f comm (commandmacros env)
-             commandmacros = Map.insert f comm (commandmacros env)
+             }
-             }
+           }
-           }
+         _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv
-         _ -> putStrLnFlush "command definition not parsed" >> loopNewCPU gfenv
+
-
+    "dt":f:ws -> do
-    "dt":f:"<":ws -> do
+       case readTree (unwords ws) of
-       case readCommandLine (unwords ws) of
+         Just exp -> loopNewCPU $ gfenv {
-         Just [pip] -> do
+           commandenv = env {
-           ip <- interpretPipe env pip
+             expmacros = Map.insert f exp (expmacros env)
-           case ip of
+             }
-             (exp:es,_) -> do 
+           }
-               if null es then return () else
+         _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv
-                 putStrLnFlush $ "ambiguous definition, selected the first one"
+
-               loopNewCPU $ gfenv {
+    "ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
-                 commandenv = env {
+    "q":_  -> putStrLn "See you." >> return gfenv
-                   expmacros = Map.insert f exp (expmacros env)
+
-                   }
+  -- ordinary commands, working on CommandEnv
-                 }
+    _ -> do
-             _ -> putStrLnFlush "no value given in definition" >> loopNewCPU gfenv
+      interpretCommandLine env s
-         _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
+      loopNewCPU gfenv
-
+
-    "dt":f:ws -> do
+importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
-       case readExp (unwords ws) of
+importInEnv gfenv opts files
-         Just exp -> loopNewCPU $ gfenv {
+    | flag optRetainResource opts =
-           commandenv = env {
+        do src <- importSource (sourcegrammar gfenv) opts files
-             expmacros = Map.insert f exp (expmacros env)
+           return $ gfenv {sourcegrammar = src}
-             }
+    | otherwise =
-           }
+        do let opts' = addOptions (setOptimization OptCSE False) opts
-         _ -> putStrLnFlush "value definition not parsed" >> loopNewCPU gfenv
+               pgf0 = multigrammar (commandenv gfenv)
-
+           pgf1 <- importGrammar pgf0 opts' files
-    "ph":_ -> mapM_ putStrLnFlush (reverse (history gfenv0)) >> loopNewCPU gfenv
+           putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
-    "q":_  -> putStrLnFlush "See you." >> return gfenv
+           return $ gfenv { commandenv = mkCommandEnv pgf1 }
-
+
-  -- ordinary commands, working on CommandEnv
+welcome = unlines [
-    _ -> 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 
+  "This is GF version "++showVersion version++". ",
-           pgf1 <- importGrammar pgf0 opts' files
+  "Some things may work.         "
-           putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
+  ]
-           return $ gfenv { commandenv = (mkCommandEnv pgf1) 
+
-             {commandmacros = commandmacros cenv0, expmacros = expmacros cenv0}}
+prompt env = absname ++ "> " where
----           return $ gfenv { commandenv = cenv0 {multigrammar = pgf1} } -- WHY NOT
+  absname = case abstractName (multigrammar env) of
-
+    "_" -> ""  --- created by new Ident handling 22/5/2008
-welcome = unlines [
+    n   -> n
-  "                              ",
+
-  "         *  *  *              ",
+data GFEnv = GFEnv {
-  "      *           *           ",
+  sourcegrammar :: Grammar, -- gfo grammar -retain
-  "    *               *         ",
+  commandenv :: CommandEnv,
-  "   *                          ",
+  history    :: [String],
-  "   *                          ",
+  cputime    :: Integer
-  "   *        * * * * * *       ",
+  }
-  "   *        *         *       ",
+
-  "    *       * * * *  *        ",
+emptyGFEnv :: GFEnv
-  "      *     *      *          ",
+emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
-  "         *  *  *              ",
+
-  "                              ",
+
-  "This is GF version "++showVersion version++". ",
+wordCompletion cmdEnv line prefix p =
-  "Some things may work.         "
+  case wc_type (take p line) of
-  ]
+    CmplCmd pref
-
+      -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
-prompt env = absname ++ "> " where
+    CmplStr (Just (Command _ opts _)) s
-  absname = case abstractName (multigrammar env) of
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat  opts)))
-    "_" -> ""  --- created by new Ident handling 22/5/2008
+            case mb_state0 of
-    n   -> n
+              Right state0 -> let ws     = words (take (length s - length prefix) s)
-
+                                  state  = foldl nextState state0 ws
-data GFEnv = GFEnv {
+                                  compls = getCompletions state prefix
-  sourcegrammar :: Grammar, -- gfo grammar -retain
+                              in ret ' ' (Map.keys compls)
-  commandenv :: CommandEnv,
+              Left  _      -> ret ' ' []
-  history    :: [String],
+    CmplOpt (Just (Command n _ _)) pref
-  cputime    :: Integer
+      -> 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]
-emptyGFEnv :: GFEnv
+                          ret (if null flg_compls then ' ' else '=')
-emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
+                              (flg_compls++opt_compls)
-
+           Nothing  -> ret ' ' []
-
+    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
-wordCompletion cmdEnv line prefix p =
+      -> filenameCompletionFunction prefix
-  case wc_type (take p line) of
+    CmplIdent _ pref
-    CmplCmd pref
+      -> do mb_abs <- try (evaluate (abstract pgf))
-      -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+            case mb_abs of
-    CmplStr (Just (Command _ opts _)) s
+              Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
-      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat  opts)))
+              Left  _   -> ret ' ' []
-            case mb_state0 of
+    _ -> ret ' ' []
-              Right state0 -> let ws     = words (take (length s - length prefix) s)
+  where
-                                  state  = foldl nextState state0 ws
+    pgf = multigrammar cmdEnv
-                                  compls = getCompletions state prefix
+    optLang opts = valIdOpts "lang" (head (languages pgf)) opts
-                              in ret ' ' (Map.keys compls)
+    optCat  opts = valIdOpts "cat"  (lookStartCat pgf)     opts
-              Left  _      -> ret ' ' []
+    
-    CmplOpt (Just (Command n _ _)) pref
+    ret c [x] = return [x++[c]]
-      -> case Map.lookup n (commands cmdEnv) of
+    ret _ xs  = return xs
-           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 '=')
+data CompletionType
-                              (flg_compls++opt_compls)
+  = CmplCmd                   Ident
-           Nothing  -> ret ' ' []
+  | CmplStr   (Maybe Command) String
-    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
+  | CmplOpt   (Maybe Command) Ident
-      -> filenameCompletionFunction prefix
+  | CmplIdent (Maybe Command) Ident
-    CmplIdent _ pref
+  deriving Show
-      -> do mb_abs <- try (evaluate (abstract pgf))
+
-            case mb_abs of
+wc_type :: String -> CompletionType
-              Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
+wc_type = cmd_name
-              Left  _   -> ret ' ' []
+  where
-    _ -> ret ' ' []
+    cmd_name cs =
-  where
+      let cs1 = dropWhile isSpace cs
-    pgf = multigrammar cmdEnv
+      in go cs1 cs1
-    optLang opts = valIdOpts "lang" (head (languages pgf)) opts
+      where
-    optCat  opts = valIdOpts "cat"  (lookStartCat pgf)     opts
+        go x []       = CmplCmd x
-    
+        go x (c:cs)
-    ret c [x] = return [x++[c]]
+          | isIdent c = go x cs
-    ret _ xs  = return xs
+          | otherwise = cmd x cs
-
+
-
+    cmd x []       = ret CmplIdent x "" 0
-data CompletionType
+    cmd _ ('|':cs) = cmd_name cs
-  = CmplCmd                   Ident
+    cmd _ (';':cs) = cmd_name cs
-  | CmplStr   (Maybe Command) String
+    cmd x ('"':cs) = str x cs cs
-  | CmplOpt   (Maybe Command) Ident
+    cmd x ('-':cs) = option x cs cs
-  | CmplIdent (Maybe Command) Ident
+    cmd x (c  :cs)
-  deriving Show
+      | isIdent c  = ident x (c:cs) cs
-
+      | otherwise  = cmd x cs
-wc_type :: String -> CompletionType
+
-wc_type = cmd_name
+    option x y []     = ret CmplOpt x y 1
-  where
+    option x y (c:cs)
-    cmd_name cs =
+      | isIdent c     = option x y cs
-      let cs1 = dropWhile isSpace cs
+      | otherwise     = cmd x cs
-      in go cs1 cs1
+
-      where
+    ident x y []     = ret CmplIdent x y 0
-        go x []       = CmplCmd x
+    ident x y (c:cs)
-        go x (c:cs)
+      | isIdent c    = ident x y cs
-          | isIdent c = go x cs
+      | otherwise    = cmd x cs
-          | otherwise = cmd x cs
+
-
+    str x y []          = ret CmplStr x y 1
-    cmd x []       = ret CmplIdent x "" 0
+    str x y ('\"':cs)   = cmd x cs
-    cmd _ ('|':cs) = cmd_name cs
+    str x y ('\\':c:cs) = str x y cs
-    cmd _ (';':cs) = cmd_name cs
+    str x y (c:cs)      = str x y cs
-    cmd x ('"':cs) = str x cs cs
+
-    cmd x ('-':cs) = option x cs cs
+    ret f x y d = f cmd y
-    cmd x (c  :cs)
+      where
-      | isIdent c  = ident x (c:cs) cs
+        x1 = take (length x - length y - d) x
-      | otherwise  = cmd x cs
+        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1
-
+        
-    option x y []     = ret CmplOpt x y 1
+        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-    option x y (c:cs)
+	        [x] -> Just x
-      | isIdent c     = option x y cs
+                _   -> Nothing
-      | otherwise     = cmd x cs
+
-
+    isIdent c = c == '_' || c == '\'' || isAlphaNum c
-    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

src-3.0/PGF.hs

@@ -28,8 +28,13 @@ module PGF(
            Category, categories, startCat,
 
            -- * Expressions
-           Exp(..), Equation(..),
+           -- ** Tree
-           showExp, readExp,
+           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]

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
+  aflags  :: Map.Map CId String,      -- value of a flag
-  funs    :: Map.Map CId (Type,Exp), -- type and def of a fun
+  funs    :: Map.Map CId (Type,Expr), -- type and def of a fun
-  cats    :: Map.Map CId [Hypo],     -- context of a cat
+  cats    :: Map.Map CId [Hypo],      -- context of a cat
-  catfuns :: Map.Map CId [CId]       -- funs to a cat (redundant, for fast lookup)
+  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
+data Literal = 
--- in PGF. The same expression is used in the dependent
+   LStr String                      -- ^ string constant
--- types.
+ | LInt Integer                     -- ^ integer constant
-data Exp =
+ | LFlt Double                      -- ^ floating point constant
-   EAbs [CId] Exp                   -- ^ lambda abstraction. The list should contain at least one variable
+ deriving (Eq,Ord,Show)
- | EApp CId [Exp]                   -- ^ application. Note that unevaluated lambda abstractions are not allowed
+
- | EStr   String                    -- ^ string constant
+-- | The tree is an evaluated expression in the abstract syntax
- | EInt   Integer                   -- ^ integer constant
+-- of the grammar. The type is especially restricted to not
- | EFloat Double                    -- ^ floating point constant
+-- 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 =
+data Alternative =
-   Var [String] [String]
+   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
+-- of equations with pattern matching. The list of 'Expr' represents
--- the patterns and the second 'Exp' is the function body for this
+-- 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)
 
 

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

src-3.0/PGF/ExprSyntax.hs

@@ -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

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 "String" = (Lit (LStr "foo"), 1)
-    gett ds cid | cid == mkCId "Int"    = (EInt 12345, 1)
+    gett ds cid | cid == mkCId "Int"    = (Lit (LInt 12345), 1)
-    gett [] _   = (EStr "TIMEOUT", 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

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 -> CId -> Tree -> String
-linearize pgf lang = realize . linExp pgf lang
+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
+linTree :: PGF -> CId -> Tree -> Term
-linExp pgf lang = lin
+linTree pgf lang = lin
   where
-    lin (EAbs   xs  e ) = case lin e of
+    lin (Abs xs  e )   = case lin e of
-                            R ts -> R $ ts     ++ (Data.List.map (kks . prCId) xs)
+                             R ts -> R $ ts     ++ (Data.List.map (kks . prCId) xs)
-                            TM s -> R $ (TM s)  : (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 (Fun fun es)   = comp (map lin es) $ look fun
-    lin (EStr   s     ) = R [kks (show s)] -- quoted
+    lin (Lit (LStr s)) = R [kks (show s)] -- quoted
-    lin (EInt   i     ) = R [kks (show i)] 
+    lin (Lit (LInt i)) = R [kks (show i)] 
-    lin (EFloat d     ) = R [kks (show d)]
+    lin (Lit (LFlt d)) = R [kks (show d)]
-    lin (EVar   x     ) = TM (prCId x)
+    lin (Var x)        = TM (prCId x)
-    lin (EMeta  i     ) = TM (show i)
+    lin (Meta i)       = TM (show i)
  
     comp = compute pgf lang
     look = lookLin pgf lang

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 :: Tree -> Int
-depth (EAbs _  t) = depth t
+depth (Abs _  t) = depth t
-depth (EApp _ ts) = maximum (0:map depth ts) + 1
+depth (Fun _ ts) = maximum (0:map depth ts) + 1
-depth _           = 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

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 

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 :: String -> ParserInfo -> CId -> [FToken] -> [Tree]
-parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2exps
+parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees
   where
     inTokens = input toks
     starts = Map.findWithDefault [] start (startupCats pinfo)

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

src-3.0/PGF/Parsing/FCFG/Utilities.hs

@@ -179,9 +179,9 @@ applyProfileToForest (FFloat  f) = [FFloat  f]
 applyProfileToForest (FMeta)     = [FMeta]
 
 
-forest2exps :: SyntaxForest CId -> [Exp]
+forest2trees :: SyntaxForest CId -> [Tree]
-forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps
+forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees
-forest2exps (FString s) = [EStr   s]
+forest2trees (FString s) = [Lit (LStr s)]
-forest2exps (FInt    n) = [EInt   n]
+forest2trees (FInt    n) = [Lit (LInt n)]
-forest2exps (FFloat  f) = [EFloat f]
+forest2trees (FFloat  f) = [Lit (LFlt f)]
-forest2exps (FMeta)     = [EMeta  0]
+forest2trees (FMeta)     = [Meta 0]

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 "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
-  App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps)
+  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
+  AInt i -> ELit (LInt i)
-  AFlt i -> EFloat i
+  AFlt i -> ELit (LFlt i)
-  AStr i -> EStr   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]
+  EAbs x exp   -> App "Abs" [App (prCId x) [], fromExp exp]
-  EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps)
+  EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
   EVar   x -> App "Var" [App (prCId x) []]
-  EStr   s -> AStr s
+  ELit (LStr s) -> AStr s
-  EFloat d -> AFlt d
+  ELit (LFlt d) -> AFlt d
-  EInt   i -> AInt (toInteger i)
+  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)
 

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 -> CId -> Tree -> Record
-recLinearize pgf lang exp = mkRecord typ $ linExp pgf lang exp where
+recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
-  typ = case exp of
+  typ = case tree of
-          EApp f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
+          Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
 
 -- show PGF term
-termLinearize :: PGF -> CId -> Exp -> String
+termLinearize :: PGF -> CId -> Tree -> String
-termLinearize pgf lang = show . linExp pgf lang
+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]