majestic: Type-checking improvements + unifying overload resolution + simple REPL

.gitignore

@@ -56,6 +56,12 @@ DATA_DIR
 
 stack*.yaml.lock
 
+# Generated source files
+src/compiler/api/GF/Grammar/Lexer.hs
+src/compiler/api/GF/Grammar/Parser.hs
+src/compiler/api/PackageInfo_gf.hs
+src/compiler/api/Paths_gf.hs
+
 # Output files for test suite
 *.out
 gf-tests.html

src/compiler/api/GF/Compile/Compute/Concrete.hs

@@ -26,6 +26,7 @@ import GF.Grammar.Predef
 import GF.Grammar.Lockfield(lockLabel)
 import GF.Grammar.Printer
 import GF.Data.Operations(Err(..))
+import GF.Data.Utilities((<||>),anyM)
 import GF.Infra.CheckM
 import GF.Infra.Option
 import Data.STRef
@@ -142,6 +143,37 @@ showValue (VAlts _ _) = "VAlts"
 showValue (VStrs _) = "VStrs"
 showValue (VSymCat _ _ _) = "VSymCat"
 
+isOpen :: [Ident] -> Term -> EvalM s Bool
+isOpen bound (Vr x) = return $ x `notElem` bound
+isOpen bound (App f x) = isOpen bound f <||> isOpen bound x
+isOpen bound (Abs b x t) = isOpen (x:bound) t
+isOpen bound (ImplArg t) = isOpen bound t
+isOpen bound (Prod b x d cod) = isOpen bound d <||> isOpen (x:bound) cod
+isOpen bound (Typed t ty) = isOpen bound t
+isOpen bound (Example t s) = isOpen bound t
+isOpen bound (RecType fs) = anyM (isOpen bound . snd) fs
+isOpen bound (R fs) = anyM (isOpen bound . snd . snd) fs
+isOpen bound (P t f) = isOpen bound t
+isOpen bound (ExtR t t') = isOpen bound t <||> isOpen bound t'
+isOpen bound (Table d cod) = isOpen bound d <||> isOpen bound cod
+isOpen bound (T (TTyped ty) cs) = isOpen bound ty <||> anyM (isOpen bound . snd) cs
+isOpen bound (T (TWild ty) cs) = isOpen bound ty <||> anyM (isOpen bound . snd) cs
+isOpen bound (T _ cs) = anyM (isOpen bound . snd) cs
+isOpen bound (V ty cs) = isOpen bound ty <||> anyM (isOpen bound) cs
+isOpen bound (S t x) = isOpen bound t <||> isOpen bound x
+isOpen bound (Let (x,(ty,d)) t) = isOpen bound d <||> isOpen (x:bound) t
+isOpen bound (C t t') = isOpen bound t <||> isOpen bound t'
+isOpen bound (Glue t t') = isOpen bound t <||> isOpen bound t'
+isOpen bound (EPattType ty) = isOpen bound ty
+isOpen bound (ELincat c ty) = isOpen bound ty
+isOpen bound (ELin c t) = isOpen bound t
+isOpen bound (FV ts) = anyM (isOpen bound) ts
+isOpen bound (Markup tag as ts) = anyM (isOpen bound) ts <||> anyM (isOpen bound . snd) as
+isOpen bound (Reset c t) = isOpen bound t
+isOpen bound (Alts d as) = isOpen bound d <||> anyM (\(x,y) -> isOpen bound x <||> isOpen bound y) as
+isOpen bound (Strs ts) = anyM (isOpen bound) ts
+isOpen _ _ = return False
+
 eval env (Vr x)         vs  = do (tnk,depth) <- lookup x env
                                  withVar depth $ do
                                    v <- force tnk
@@ -207,12 +239,14 @@ eval env (S t1 t2)      vs  = do v1   <- eval env t1 []
 eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
                                      eval ((x,tnk):env) t2 vs
 eval env (Q q@(m,id))   vs
-  | m == cPredef            = do vs' <- mapM force vs
-                                 res <- evalPredef id vs'
-                                 case res of
-                                   Const res -> return res
-                                   RunTime   -> return (VApp q vs)
-                                   NonExist  -> return (VApp (cPredef,cNonExist) [])
+  | m == cPredef            = do vs' <- mapM force vs -- FIXME this does not allow for partial application!
+                                 open <- anyM (value2term True [] >=> isOpen []) vs'
+                                 if open then return (VApp q vs) else do
+                                   res <- evalPredef id vs'
+                                   case res of
+                                     Const res -> return res
+                                     RunTime   -> return (VApp q vs)
+                                     NonExist  -> return (VApp (cPredef,cNonExist) [])
   | otherwise               = do t <- getResDef q
                                  eval env t vs
 eval env (QC q)         vs  = return (VApp q vs)

src/compiler/api/GF/Compile/Repl.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE LambdaCase #-}
+
+module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where
+
+import Control.Monad (unless, forM_, foldM)
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.ByteString.Char8 as BS
+import Data.Char (isSpace)
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import qualified Data.Map as Map
+
+import System.Console.GetOpt (ArgOrder(RequireOrder), OptDescr(..), ArgDescr(..), getOpt, usageInfo)
+import System.Console.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn)
+import System.Directory (getAppUserDataDirectory)
+
+import GF.Compile (batchCompile)
+import GF.Compile.Compute.Concrete (Globals(Gl), stdPredef, normalFlatForm)
+import GF.Compile.Rename (renameSourceTerm)
+import GF.Compile.TypeCheck.ConcreteNew (inferLType)
+import GF.Data.ErrM (Err(..))
+import GF.Grammar.Grammar
+  ( Grammar
+  , mGrammar
+  , Info
+  , Module
+  , ModuleName
+  , ModuleInfo(..)
+  , ModuleType(MTResource)
+  , ModuleStatus(MSComplete)
+  , OpenSpec(OSimple)
+  , Location (NoLoc)
+  , Term
+  , prependModule
+  )
+import GF.Grammar.Lexer (Posn(..), Lang(GF), runLangP)
+import GF.Grammar.Parser (pTerm)
+import GF.Grammar.Printer (TermPrintQual(Unqualified), ppTerm)
+import GF.Infra.CheckM (Check, runCheck)
+import GF.Infra.Ident (moduleNameS)
+import GF.Infra.Option (noOptions)
+import GF.Infra.UseIO (justModuleName)
+import GF.Text.Pretty (render)
+
+data ReplOpts = ReplOpts
+  { noPrelude :: Bool
+  , inputFiles :: [String]
+  }
+
+defaultReplOpts :: ReplOpts
+defaultReplOpts = ReplOpts False []
+
+type Errs a = Either [String] a
+type ReplOptsOp = ReplOpts -> Errs ReplOpts
+
+replOptDescrs :: [OptDescr ReplOptsOp]
+replOptDescrs =
+  [ Option ['h'] ["help"] (NoArg $ \o -> Left [usageInfo "gfci" replOptDescrs]) "Display help."
+  , Option [] ["no-prelude"] (flag $ \o -> o { noPrelude = True }) "Don't load the prelude."
+  ]
+  where
+    flag f = NoArg $ \o -> pure (f o)
+
+getReplOpts :: [String] -> Errs ReplOpts
+getReplOpts args = case errs of
+  [] -> foldM (&) defaultReplOpts flags <&> \o -> o { inputFiles = inputFiles }
+  _  -> Left errs
+  where
+    (flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args
+
+execCheck :: MonadIO m => Check a -> (a -> InputT m ()) -> InputT m ()
+execCheck c k = case runCheck c of
+  Ok (a, warn) -> do
+    unless (null warn) $ outputStrLn warn
+    k a
+  Bad err -> outputStrLn err
+
+replModNameStr :: String
+replModNameStr = "<repl>"
+
+replModName :: ModuleName
+replModName = moduleNameS replModNameStr
+
+parseThen :: MonadIO m => Grammar -> String -> (Term -> InputT m ()) -> InputT m ()
+parseThen g s k = case runLangP GF pTerm (BS.pack s) of
+  Left (Pn l c, err) -> outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")"
+  Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t
+
+runRepl' :: Globals -> IO ()
+runRepl' gl@(Gl g _) = do
+  historyFile <- getAppUserDataDirectory "gfci_history"
+  runInputT (Settings noCompletion (Just historyFile) True) repl -- TODO tab completion
+  where
+    repl = do
+      getInputLine "gfci> " >>= \case
+        Nothing -> repl
+        Just (':' : l) -> let (cmd, arg) = break isSpace l in command cmd (dropWhile isSpace arg)
+        Just code -> evalPrintLoop code
+
+    command "t" arg = do
+      parseThen g arg $ \main ->
+        execCheck (inferLType gl main) $ \(_, ty) ->
+          outputStrLn $ render (ppTerm Unqualified 0 ty)
+      outputStrLn "" >> repl
+
+    command "q" _ = outputStrLn "Bye!"
+
+    command cmd _ = do
+      outputStrLn $ "Unknown REPL command: " ++ cmd
+      outputStrLn "" >> repl
+
+    evalPrintLoop code = do -- TODO bindings
+      parseThen g code $ \main ->
+        execCheck (inferLType gl main >>= \(t, _) -> normalFlatForm gl t) $ \nfs ->
+          forM_ (zip [1..] nfs) $ \(i, nf) ->
+            outputStrLn $ show i ++ ". " ++ render (ppTerm Unqualified 0 nf)
+      outputStrLn "" >> repl
+
+runRepl :: ReplOpts -> IO ()
+runRepl (ReplOpts noPrelude inputFiles) = do
+  -- TODO accept an ngf grammar
+  let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles
+  (g0, opens) <- case toLoad of
+    [] -> pure (mGrammar [], [])
+    _ -> do
+      (_, (_, g0)) <- batchCompile noOptions Nothing toLoad
+      pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
+  let
+    modInfo = ModInfo
+      { mtype   = MTResource
+      , mstatus = MSComplete
+      , mflags  = noOptions
+      , mextend = []
+      , mwith   = Nothing
+      , mopens  = opens
+      , mexdeps = []
+      , msrc    = replModNameStr
+      , mseqs   = Nothing
+      , jments  = Map.empty
+      }
+  runRepl' (Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef))