mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-02 15:52:50 -06:00
147 lines
4.8 KiB
Haskell
147 lines
4.8 KiB
Haskell
{-# 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.Concrete2 (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(Typed)
|
|
, 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) $ \res ->
|
|
forM_ res $ \(t, ty) ->
|
|
let t' = case t of
|
|
Typed _ _ -> t
|
|
t -> Typed t ty
|
|
in outputStrLn $ render (ppTerm Unqualified 0 t')
|
|
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
|
|
}
|
|
g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g)
|
|
runRepl' g
|