hopefully complete and correct typechecker in PGF

5 files changed, 109 insertions, 119 deletions

diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index 07d710e0a..65f64ef11 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -32,6 +32,7 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
 import GF.Data.Operations
 import GF.Text.Coding
 
+import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
 import System.Cmd
@@ -283,7 +284,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
           _ | isOpt "changes" opts -> changesMsg
           _ | isOpt "coding" opts -> codingMsg
           _ | isOpt "license" opts -> licenseMsg
-          [t] -> let co = getCommandOp (showExpr t) in 
+          [t] -> let co = getCommandOp (showExpr [] t) in 
                  case lookCommand co (allCommands cod env) of   ---- new map ??!!
                    Just info -> commandHelp True (co,info)
                    _ -> "command not found"
@@ -615,23 +616,29 @@ allCommands cod env@(pgf, mos) = Map.fromList [
        ],
      exec = \opts arg -> do
        case arg of
-         [EVar id] -> case Map.lookup id (funs (abstract pgf)) of
+         [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
                         Just (ty,_,eqs) -> return $ fromString $
-                                              render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 ty $$
+                                              render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 [] ty $$
                                                       if null eqs
                                                         then empty
-                                                        else text "def" <+> vcat [text (prCId id) <+> hsep (map (ppPatt 9) patts) <+> char '=' <+> ppExpr 0 res | Equ patts res <- eqs])
+                                                        else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
+                                                                                  in text (prCId id) <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
                         Nothing         -> case Map.lookup id (cats (abstract pgf)) of
                                              Just hyps -> do return $ fromString $
-                                                                render (text "cat" <+> text (prCId id) <+> hsep (map ppHypo hyps) $$
+                                                                render (text "cat" <+> text (prCId id) <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$
                                                                         if null (functionsToCat pgf id)
                                                                           then empty
                                                                           else space $$
-                                                                               text "fun" <+> vcat [text (prCId fid) <+> colon <+> ppType 0 ty 
+                                                                               text "fun" <+> vcat [text (prCId fid) <+> colon <+> ppType 0 [] ty 
                                                                                                        | (fid,ty) <- functionsToCat pgf id])
                                              Nothing   -> do putStrLn "unknown identifier"
                                                              return void
-         _           -> do putStrLn "a single identifier is expected from the command"
+         [e]         -> case inferExpr pgf e of
+                          Left tcErr   -> error $ render (ppTcError tcErr)
+                          Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
+                                             putStrLn ("Type:       "++showType [] ty)
+                                             return void
+         _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void
      })
   ]
@@ -689,7 +696,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
    optType opts = 
      let str = valStrOpts "cat" (prCId $ lookStartCat pgf) opts
      in case readType str of
-          Just ty -> ty
+          Just ty -> case checkType pgf ty of
+                       Left tcErr -> error $ render (ppTcError tcErr)
+                       Right ty   -> ty
           Nothing -> error ("Can't parse '"++str++"' as type")
    optComm opts = valStrOpts "command" "" opts
    optViewFormat opts = valStrOpts "format" "png" opts
@@ -710,10 +719,10 @@ allCommands cod env@(pgf, mos) = Map.fromList [
 
    returnFromExprs es = return $ case es of
      [] -> ([], "no trees found")
-     _  -> (es,unlines (map showExpr es))
+     _  -> (es,unlines (map (showExpr []) es))
 
    prGrammar opts
-     | isOpt "cats"     opts = return $ fromString $ unwords $ map showType $ categories pgf
+     | isOpt "cats"     opts = return $ fromString $ unwords $ map (showType []) $ categories pgf
      | isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts
      | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (prCId la:":": map prCId cs) | 
                                                                   la <- optLangs opts, let cs = missingLins pgf la]
@@ -739,7 +748,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
 
    showAsString t = case t of
      ELit (LStr s) -> s
-     _ -> "\n" ++ showExpr t  --- newline needed in other cases than the first
+     _ -> "\n" ++ showExpr [] t  --- newline needed in other cases than the first
 
 stringOpOptions = sort $ [
        ("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs
index 23b928ed6..2ace4cde6 100644
--- a/src/GF/Command/Interpreter.hs
+++ b/src/GF/Command/Interpreter.hs
@@ -12,14 +12,13 @@ import GF.Command.Abstract
 import GF.Command.Parse
 import PGF
 import PGF.Data
-import PGF.Macros
 import PGF.Morphology
 import GF.System.Signal
 import GF.Infra.UseIO
 import GF.Infra.Option
 
-import GF.Data.ErrM ----
-
+import Text.PrettyPrint
+import Control.Monad.Error
 import qualified Data.Map as Map
 
 data CommandEnv = CommandEnv {
@@ -43,12 +42,6 @@ interpretCommandLine enc env line =
   case readCommandLine line of
     Just []    -> return ()
     Just pipes -> mapM_ (interpretPipe enc env) pipes
-{-
-    Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe enc env) pipes)
-                     case res of
-                       Left ex -> putStrLnFlush $ enc (show ex)
-                       Right x -> return x
--}
     Nothing    -> putStrLnFlush "command not parsed"
 
 interpretPipe enc env cs = do
@@ -60,12 +53,15 @@ interpretPipe enc env cs = do
    intercs (trees,_) (c:cs) = do
      treess2 <- interc trees c
      intercs treess2 cs
-   interc es comm@(Command co _ arg) = case co of
+   interc es comm@(Command co opts arg) = case co of
      '%':f -> case Map.lookup f (commandmacros env) of
-       Just css -> do
-         mapM_ (interpretPipe enc env) (appLine (getCommandArg env arg es) css) 
-         return ([],[]) ---- return ?
-       _ -> do
+       Just css ->
+         case getCommandTrees env arg es of
+           Right es -> do mapM_ (interpretPipe enc env) (appLine es css) 
+                          return ([],[])
+           Left msg -> do putStrLn ('\n':msg)
+                          return ([],[])
+       Nothing  -> do
          putStrLn $ "command macro " ++ co ++ " not interpreted"
          return ([],[])
      _ -> interpret enc env es comm
@@ -82,43 +78,53 @@ appCommand xs c@(Command i os arg) = case arg of
     EApp e1 e2 -> EApp (app e1) (app e2)
     ELit l     -> ELit l
     EMeta i    -> xs !! i
-    EVar x     -> EVar x
+    EFun x     -> EFun x
 
 -- return the trees to be sent in pipe, and the output possibly printed
 interpret :: (String -> String) -> CommandEnv -> [Expr] -> Command -> IO CommandOutput
-interpret enc env trees0 comm = case lookCommand co comms of
-    Just info -> do
-      checkOpts info
-      tss@(_,s) <- exec info opts trees
-      optTrace $ enc s
-      return tss
-    _ -> do
-      putStrLn $ "command " ++ co ++ " not interpreted"
-      return ([],[])
- where
-   optTrace = if isOpt "tr" opts then putStrLn else const (return ()) 
-   (co,opts,trees) = getCommand env comm trees0
-   comms = commands env
-   checkOpts info = 
-     case
-       [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
-       [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
-      of
-        []  -> return () 
-        [o] -> putStrLn $ "option not interpreted: " ++ o
-        os  -> putStrLn $ "options not interpreted: " ++ unwords os
+interpret enc env trees comm = 
+  case getCommand env trees comm of
+    Left  msg               -> do putStrLn ('\n':msg)
+                                  return ([],[])
+    Right (info,opts,trees) -> do tss@(_,s) <- exec info opts trees
+                                  if isOpt "tr" opts
+                                    then putStrLn (enc s)
+                                    else return ()
+                                  return tss
 
 -- analyse command parse tree to a uniform datastructure, normalizing comm name
 --- the env is needed for macro lookup
-getCommand :: CommandEnv -> Command -> [Expr] -> (String,[Option],[Expr])
-getCommand env co@(Command c opts arg) ts = 
-  (getCommandOp c,opts,getCommandArg env arg ts) 
+getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo,[Option],[Expr])
+getCommand env es co@(Command c opts arg) = do
+  info <- getCommandInfo  env c
+  checkOpts info opts
+  es   <- getCommandTrees env arg es
+  return (info,opts,es)
+
+getCommandInfo :: CommandEnv -> String -> Either String CommandInfo
+getCommandInfo env cmd = 
+  case lookCommand (getCommandOp cmd) (commands env) of
+    Just info -> return info
+    Nothing   -> fail $ "command " ++ cmd ++ " not interpreted"
 
-getCommandArg :: CommandEnv -> Argument -> [Expr] -> [Expr]
-getCommandArg env a ts = case a of
-  AMacro m -> case Map.lookup m (expmacros env) of
-    Just t -> [t]
-    _ -> [] 
-  AExpr t -> [t] -- ignore piped
-  ANoArg  -> ts  -- use piped
+checkOpts :: CommandInfo -> [Option] -> Either String ()
+checkOpts info opts = 
+  case
+    [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
+    [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+  of
+    []  -> return () 
+    [o] -> fail $ "option not interpreted: " ++ o
+    os  -> fail $ "options not interpreted: " ++ unwords os
 
+getCommandTrees :: CommandEnv -> Argument -> [Expr] -> Either String [Expr]
+getCommandTrees env a es =
+  case a of
+    AMacro m -> case Map.lookup m (expmacros env) of
+                  Just e -> return [e]
+                  _      -> return [] 
+    AExpr e -> case inferExpr (multigrammar env) e of
+                 Left tcErr   -> fail $ render (ppTcError tcErr)
+                 Right (e,ty) -> return [e] -- ignore piped
+    ANoArg  -> return es  -- use piped
+  
diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs
index 262ce35b5..45f927afc 100644
--- a/src/GF/Command/TreeOperations.hs
+++ b/src/GF/Command/TreeOperations.hs
@@ -20,9 +20,7 @@ allTreeOps pgf = [
    ("paraphrase",("paraphrase by using semantic definitions (def)",
       map tree2expr . nub . concatMap (paraphrase pgf . expr2tree))),
    ("smallest",("sort trees from smallest to largest, in number of nodes",
-      smallest)),
-   ("typecheck",("type check and solve metavariables; reject if incorrect",
-      concatMap (typecheck pgf)))
+      smallest))
   ]
 
 smallest :: [Expr] -> [Expr]
@@ -31,35 +29,3 @@ smallest = sortBy (\t u -> compare (size t) (size u)) where
     EAbs _ e -> size e + 1
     EApp e1 e2 -> size e1 + size e2 + 1
     _ -> 1
-
-{-
-toTree :: G.Term -> Tree
-toTree t = case M.termForm t of
-  Ok (xx,f,aa) -> Abs xx (Fun f (map toTree aa))
-
-fromTree :: Tree -> G.Term
-fromTree t = case t of
-  Abs xx b -> M.mkAbs xx (fromTree b)
-  Var x    -> M.vr x
-  Fun f ts -> M.mkApp f (map fromTree ts)
--}
-
-{-
-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
-
-data Literal = 
-   LStr String                      -- ^ string constant
- | LInt Integer                     -- ^ integer constant
- | LFlt Double                      -- ^ floating point constant
-
-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.Expr
--}
diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs
index dca6465fa..3e30dccc3 100644
--- a/src/GF/Compile/GFCCtoProlog.hs
+++ b/src/GF/Compile/GFCCtoProlog.hs
@@ -68,7 +68,7 @@ plAbstract (name, Abstr aflags funs cats _catfuns) =
 plCat :: (CId, [Hypo]) -> String
 plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) 
     where ((_,subst), hypos') = alphaConvert emptyEnv hypos
-          args = reverse [EVar x | (_,x) <- subst]
+          args = reverse [EFun x | (_,x) <- subst]
           typ = DTyp hypos' cat args
 
 plFun :: (CId, (Type, Int, [Equation])) -> String
@@ -119,7 +119,7 @@ instance PLPrint Hypo where
     plp (HypV var typ) = plOper ":" (plp var) (plp typ)
 
 instance PLPrint Expr where
-    plp (EVar x)    = plp x
+    plp (EFun x)    = plp x
     plp (EAbs x e)  = plOper "^" (plp x) (plp e)
     plp (EApp e e') = plOper " * " (plp e) (plp e')
     plp (ELit lit)  = plp lit
@@ -279,7 +279,7 @@ instance AlphaConvert Expr where
     alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
         where (env',  e1') = alphaConvert env  e1
               (env'', e2') = alphaConvert env' e2
-    alphaConvert env expr@(EVar i) = (env, maybe expr EVar (lookup i (snd env)))
+    alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
     alphaConvert env expr = (env, expr)
 
 -- pattern variables are not alpha converted
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index d7e46df3e..115f3e319 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -70,17 +70,17 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
   gflags = Map.empty
   aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)]
 
-  mkDef (Just eqs) = [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
+  mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
   mkDef Nothing    = []
   
   mkArrity (Just a) = a
   mkArrity Nothing  = 0
 
   -- concretes
-  lfuns = [(f', (mkType ty, mkArrity ma, mkDef pty)) | 
+  lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | 
              (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
   funs = Map.fromAscList lfuns
-  lcats = [(i2i c, mkContext cont) |
+  lcats = [(i2i c, snd (mkContext [] cont)) |
                 (c,AbsCat (Just cont) _) <- tree2list (M.jments abm)]
   cats = Map.fromAscList lcats
   catfuns = Map.fromList 
@@ -118,36 +118,45 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
 i2i :: Ident -> CId
 i2i = CId . ident2bs
 
-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)
+mkType :: [Ident] -> A.Type -> C.Type
+mkType scope t =
+  case GM.typeForm t of
+    Ok (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
+                              in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
 
-mkExp :: A.Term -> C.Expr
-mkExp t = case GM.termForm t of
-    Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
+mkExp :: [Ident] -> A.Term -> C.Expr
+mkExp scope t = case GM.termForm t of
+    Ok (xs,c,args) -> mkAbs xs (mkApp (reverse xs++scope) c (map (mkExp scope) args))
   where
     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)
+    mkApp scope c args = case c of
+      Q _ c    -> foldl C.EApp (C.EFun (i2i c)) args
+      QC _ c   -> foldl C.EApp (C.EFun (i2i c)) args
+      Vr x     -> case lookup x (zip scope [0..]) of
+                    Just i  -> foldl C.EApp (C.EVar  i) args
+                    Nothing -> foldl C.EApp (C.EMeta 0) args
       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.PApp (i2i c) (map mkPatt ps)
-  A.PV x      -> C.PVar (i2i x)
-  A.PW        -> C.PWild
-  A.PInt i    -> C.PLit (C.LInt i)
-  A.PFloat f  -> C.PLit (C.LFlt f)
-  A.PString s -> C.PLit (C.LStr s)
-
-
-mkContext :: A.Context -> [C.Hypo]
-mkContext hyps = [(if x == identW then C.Hyp else C.HypV (i2i x)) (mkType ty) | (x,ty) <- hyps]
+mkPatt scope p = 
+  case p of
+    A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps
+                   in (scope',C.PApp (i2i c) ps')
+    A.PV x      -> (x:scope,C.PVar (i2i x))
+    A.PW        -> (  scope,C.PWild)
+    A.PInt i    -> (  scope,C.PLit (C.LInt i))
+    A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
+    A.PString s -> (  scope,C.PLit (C.LStr s))
+
+
+mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
+mkContext scope hyps = mapAccumL (\scope (x,ty) -> let ty' = mkType scope ty
+                                                   in if x == identW
+                                                        then (  scope,C.Hyp          ty')
+                                                        else (x:scope,C.HypV (i2i x) ty')) scope hyps 
 
 mkTerm :: Term -> C.Term
 mkTerm tr = case tr of