diff --git a/funcons-tools.cabal b/funcons-tools.cabal --- a/funcons-tools.cabal +++ b/funcons-tools.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: funcons-tools -version: 0.2.0.9 +version: 0.2.0.10 synopsis: A modular interpreter for executing funcons description: The PLanCompS project () has developed a component-based approach to formal semantics. @@ -45,7 +45,7 @@ , Funcons.RunOptions build-depends: base >=4.8 && <= 5 ,text >= 1.2 - ,containers >= 0.5 && <= 0.6.0.1 + ,containers >= 0.5 && < 0.7 ,vector>=0.12 ,bv >= 0.5 ,multiset >= 0.3 @@ -57,6 +57,7 @@ ,regex-applicative ,random-strings ,funcons-values >= 0.1.0.5 + ,readline >= 1.0.3.0 hs-source-dirs: src, cbs, manual default-language: Haskell2010 other-extensions: OverloadedStrings @@ -136,12 +137,12 @@ , Funcons.Core.Values.TypesBuiltin , Funcons.Core.Computations.TypesBuiltin -executable runfct - main-is: Main.hs +executable funcons-repl + main-is: REPL.hs other-extensions: OverloadedStrings build-depends: base >=4.8 && <= 5 ,text >= 1.2 - ,containers >= 0.5 && <= 0.6.0.1 + ,containers >= 0.5 && < 0.7 ,vector>=0.12 ,bv >= 0.5 ,funcons-tools @@ -154,6 +155,8 @@ ,regex-applicative ,random-strings ,funcons-values >= 0.1.0.5 + ,exploring-interpreters >= 0.3.0.0 + ,readline >= 1.0.3.0 hs-source-dirs: src, manual, cbs default-language: Haskell2010 -- ghc-options: -rtsopts @@ -176,6 +179,7 @@ Funcons.Core.Computations.Normal.Linking.Linking Funcons.Core.Computations.Normal.Storing.Storing Funcons.Core.Computations.TypesBuiltin + Funcons.Core Funcons.Core.Library Funcons.Core.Manual Funcons.Core.Values.Abstraction.Functions.Functions @@ -230,4 +234,4 @@ Funcons.Tools Funcons.TypeSubstitution Funcons.Types - + Funcons.Explorer diff --git a/src/Funcons/Explorer.hs b/src/Funcons/Explorer.hs new file mode 100644 --- /dev/null +++ b/src/Funcons/Explorer.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, LambdaCase #-} + +module Funcons.Explorer where + +import qualified Language.Explorer.Monadic as EI + +import Funcons.EDSL hiding (isMap) +import Funcons.Operations (isMap, Values(Map)) +import Funcons.MSOS +import Funcons.RunOptions +import Funcons.Core +import Funcons.Core.Library +import Funcons.Core.Manual +import Funcons.Entities +import Funcons.Tools +import Funcons.Parser +import Funcons.Printer + +import Control.Monad (forM_) +import Data.IORef +import qualified Data.Map as M +import Data.Char (isSpace) +import Data.Tree (drawTree) +import Text.Read (readMaybe) + +import System.Console.Readline +import System.Environment +import System.IO + +data Config = Config { + reader :: MSOSReader IO + , state :: MSOSState IO + } + deriving (Eq) + +type Explorer = EI.Explorer Funcons IO Config () + +handle_revert :: EI.Ref -> Explorer -> IO Explorer +handle_revert r exp = + case EI.revert r exp of + Just e -> return e + Nothing -> putStrLn "Invalid reference for revert" >> return exp + +repl :: IO () +repl = getArgs >>= mk_explorer >>= repl' + where + repl' exp = do + hFlush stdout + readline ("#" ++ show (EI.currRef exp) ++ " > ") >>= \case + Nothing -> return () + Just input -> do + addHistory input + case break isSpace input of + (":session", _) -> do + (putStrLn . drawTree . fmap (show . fst) . EI.toTree) exp + repl' exp + (":revert", mint) | Just ref_id' <- readMaybe (dropWhile isSpace mint) + -> handle_revert ref_id' exp >>= repl' + | otherwise -> putStrLn "Revert requires an integer argument" >> repl' exp + _ -> case fct_parse_either input of + Left err -> putStrLn err >> repl' exp + Right fct -> EI.execute fct exp >>= (repl' . fst) + + +mk_explorer :: [String] -> IO Explorer +mk_explorer args = do + (opts, unknown_opts) <- run_options args + forM_ unknown_opts $ \arg -> do + putStrLn ("unknown option: " ++ arg) + opts_ref <- newIORef opts + cfg <- mk_initial_config library entities typeenv opts + return $ EI.mkExplorerTree (\f c -> (\c -> (c, ())) <$> def_interpreter opts_ref f c) cfg + where + library = libUnions [ Funcons.Core.Library.funcons, Funcons.EDSL.library, Funcons.Core.Manual.library ] + entities = Funcons.Core.Library.entities + typeenv = Funcons.Core.Library.types + +mk_initial_config :: FunconLibrary -> EntityDefaults -> TypeRelation -> RunOptions -> IO Config +mk_initial_config lib defaults tyenv opts = do + let msos_ctxt = MSOSReader (RewriteReader lib tyenv opts f0 f0) emptyINH emptyDCTRL (fread (string_inputs opts)) + ((e_exc_f, mut, wr), rem_ins) <- + fexec (runMSOS (setEntityDefaults defaults (stepTrans opts 0 (toStepRes f0))) + msos_ctxt (emptyMSOSState {inp_es = M.empty})) (inputValues opts) + return $ Config { reader = init msos_ctxt, state = mut } + where f0 = initialise_binding_ [initialise_storing_ [map_empty_ []]] + init msos_reader = msos_reader {inh_entities = M.insert "environment" [Map M.empty] (inh_entities msos_reader) } + +def_interpreter :: IORef RunOptions -> Funcons -> Config -> IO (Maybe Config) +def_interpreter opts_ref f0' cfg = do + let f0 = give_ [f0', + give_ [if_else_ [is_ [given_, environments_], given_ + ,if_else_ [is_ [given_, null_type_], given_ + ,bind_ [Funcons.EDSL.string_ "it", given_]]] + ,if_else_ [is_ [given_, null_type_], given_ + ,sequential_ [print_ [given_,Funcons.EDSL.string_ "\n"], given_]]]] + opts <- readIORef opts_ref + let msos_ctxt = (reader cfg) { ereader = (ereader (reader cfg)) { local_fct = f0, global_fct = f0 } } + (e_exc_f, mut, wr) <- runMSOS (stepTrans opts 0 (toStepRes f0)) msos_ctxt (state cfg) + case e_exc_f of + Left ie -> putStrLn (showIException ie) >> return Nothing + Right (Left fct) -> return $ Just $ cfg { state = mut } -- did not yield an environment + Right (Right efvs) -> case filter isMap efvs of + [] -> return $ Just $ cfg { state = mut } + [env] -> return $ Just $ cfg { reader = accumulate (reader cfg) env, state = mut } + _ -> putStrLn ("multiple environments computed") >> return Nothing + where accumulate msos_reader env = msos_reader { inh_entities = M.update override "environment" (inh_entities msos_reader) } + where override [old_env] = case (env, old_env) of + (Map m1, Map m2) -> Just [Map (M.union m1 m2)] + _ -> Nothing + override _ = Nothing + +-- assumes all components of RewriteReader do not change per session +instance Eq (MSOSReader IO) where + r1 == r2 = inh_entities r1 == inh_entities r2 + && dctrl_entities r1 == dctrl_entities r2 + +-- assumes input is not used // does not change per session +instance Eq (MSOSState IO) where + s1 == s2 = mut_entities s1 == mut_entities s2 diff --git a/src/Funcons/GLLParser.hs b/src/Funcons/GLLParser.hs --- a/src/Funcons/GLLParser.hs +++ b/src/Funcons/GLLParser.hs @@ -15,6 +15,13 @@ fct_parse :: String -> Funcons fct_parse = parser_a pFuncons +fct_parse_either :: String -> Either String Funcons +fct_parse_either s = case parsesWithErrors pFuncons s of + Left err -> Left err + Right [] -> Left "no parse result" + Right [f] -> Right f + Right fs -> Left "ambiguous parse result" + fvalue_parse :: String -> Funcons fvalue_parse = FValue . fvalue_parse_ @@ -33,6 +40,9 @@ allParses :: Parser a -> String -> [a] allParses p string = GLL.Combinators.parseWithOptions [throwErrors] p (Funcons.GLLParser.lexer string) + +parsesWithErrors :: Parser a -> String -> Either String [a] +parsesWithErrors p string = GLL.Combinators.parseWithOptionsAndError [] p (Funcons.GLLParser.lexer string) fct_lexerSettings = emptyLanguage { lineComment = "//" diff --git a/src/Funcons/MSOS.hs b/src/Funcons/MSOS.hs --- a/src/Funcons/MSOS.hs +++ b/src/Funcons/MSOS.hs @@ -174,7 +174,7 @@ Just f -> Right f _ -> case M.lookup key (builtin_funcons (run_opts ctxt)) of Just f -> Right (NullaryFuncon (rewriteTo f)) - _ -> error ("unknown funcon: "++ unpack key) + _ -> Left (evalctxt2exception (Internal ("unknown funcon: "++ unpack key)) ctxt) , st, mempty) --------------------------------------------------------------------------- diff --git a/src/Funcons/Parser.hs b/src/Funcons/Parser.hs --- a/src/Funcons/Parser.hs +++ b/src/Funcons/Parser.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Funcons.Parser (fct_parse, fvalue_parse) where +module Funcons.Parser (fct_parse, fct_parse_either, fvalue_parse) where -import Funcons.GLLParser (fct_parse, fvalue_parse) +import Funcons.GLLParser (fct_parse, fct_parse_either, fvalue_parse) diff --git a/src/Funcons/Simulation.hs b/src/Funcons/Simulation.hs --- a/src/Funcons/Simulation.hs +++ b/src/Funcons/Simulation.hs @@ -10,7 +10,7 @@ import Control.Applicative import Control.Monad.State -import System.IO (hFlush,stdout) +import System.Console.Readline import qualified Data.Map as M import Data.Text (unpack) @@ -22,12 +22,14 @@ instance Interactive IO where fexec ma _ = (,M.empty) <$> ma - fread str_inp nm = (case nm of - "standard-in" -> putStr "\n> " >> hFlush stdout - _ -> putStrLn ("Please provide input for " ++ unpack nm ++ ":")) - >> getLine >>= return . toFuncon + fread str_inp nm = do + mLine <- readline prompt + case mLine of Nothing -> return (string_ "") + Just s -> addHistory s >> return (toFuncon s) where toFuncon str | str_inp = string_ str | otherwise = fvalue_parse str + prompt | nm == "standard-in" = "\n> " + | otherwise = "Please provide input for " ++ unpack nm ++ ":" fprint _ v | isString_ v = putStr (unString v) | otherwise = putStr (showValues v) diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ - -module Main where - -import Funcons.EDSL -import Funcons.Tools -import Funcons.Core.Manual as Manual - -import qualified Data.Map as M - -main :: IO () -main = mkMain - - diff --git a/src/REPL.hs b/src/REPL.hs new file mode 100644 --- /dev/null +++ b/src/REPL.hs @@ -0,0 +1,4 @@ + +import Funcons.Explorer + +main = repl