hopefully complete and correct typechecker in PGF

3 files changed, 73 insertions, 92 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
--}