diff --git a/one-sided-defs/Environment.hs b/one-sided-defs/Environment.hs index 7785991..a564ee6 100644 --- a/one-sided-defs/Environment.hs +++ b/one-sided-defs/Environment.hs @@ -9,6 +9,7 @@ module Environment ( lookupMRec, getTypeNames, getXtorNames, + getTypes, emptyEnv, addDeclEnv, addVarEnv, @@ -17,6 +18,7 @@ module Environment ( import Syntax.Typed.Program import Syntax.Typed.Terms +import Syntax.Typed.Types import Errors import Common import Loc @@ -39,6 +41,16 @@ xtorErr loc xtn = toError loc ("Xtor " <> show xtn <> " not found in environment emptyEnv :: Environment emptyEnv = MkEnv M.empty +getTypes :: Modulename -> Environment -> [(Variable,Ty)] +getTypes mn (MkEnv defs) = case M.lookup mn defs of + Nothing -> [] + Just prog -> do + let varDecls = snd <$> M.toList (progVars prog) + let vars = (\decl -> (varName decl,varTy decl)) <$> varDecls + let recDecls = snd <$> M.toList (progRecs prog) + let recs = (\decl -> (recName decl,recTy decl)) <$> recDecls + vars ++ recs + addDeclEnv :: Modulename -> DataDecl -> Environment -> Environment addDeclEnv nm decl (MkEnv defs) = case M.lookup nm defs of diff --git a/one-sided-sequent.cabal b/one-sided-sequent.cabal index 9054239..62e50ec 100644 --- a/one-sided-sequent.cabal +++ b/one-sided-sequent.cabal @@ -183,4 +183,5 @@ executable web-app eval, hs-source-dirs: web-app other-modules: Callback, - JSBits + JSBits, + StringFormat diff --git a/web-app/JSBits.hs b/web-app/JSBits.hs index 4422241..2dcc8ab 100644 --- a/web-app/JSBits.hs +++ b/web-app/JSBits.hs @@ -13,12 +13,16 @@ foreign import javascript "((arr,offset) => document.getElementById('resultStr') -- id traceStr foreign import javascript "((arr,offset) => document.getElementById('traceStr').innerHTML = h$decodeUtf8z(arr,offset))" setTraceString :: CString -> IO () +-- id typesStr +foreign import javascript "((arr,offset) => document.getElementById('typesStr').innerHTML = h$decodeUtf8z(arr,offset))" + setTypesString :: CString -> IO () -setSuccess :: String -> String -> IO () -setSuccess res tr = do +setSuccess :: String -> String -> String -> IO () +setSuccess res tr tys = do setWithString setResClass "evalSucc" setWithString setResString res setWithString setTraceString tr + setWithString setTypesString tys setError :: String -> IO () @@ -26,4 +30,5 @@ setError str = do setWithString setResClass "evalError" setWithString setResString str setWithString setTraceString "" + setWithString setTypesString "" diff --git a/web-app/Main.hs b/web-app/Main.hs index 0e1ac23..6f1a9aa 100644 --- a/web-app/Main.hs +++ b/web-app/Main.hs @@ -5,7 +5,8 @@ import Driver.Driver import Environment import Eval.Definition import Errors -import Syntax.Typed.Terms +import StringFormat + import Callback import JSBits import GHC.JS.Prim @@ -24,22 +25,10 @@ runProg val = do case res of Left err -> let msg = getMessage err in setError msg --(Either T.Command EvalTrace) - Right (Left c,_) -> setSuccess (show c) "" - Right (Right (MkTrace c tr),_) -> setSuccess (show c) (traceToStr tr) + Right (Left c,st) -> setSuccess (replStr $ show c) "" (envToStr $ drvEnv st) + Right (Right (MkTrace c tr),st) -> setSuccess (replStr $ show c) (traceToStr tr) (envToStr $ drvEnv st) return () -traceToStr :: [Command] -> String -traceToStr [] = "" -traceToStr (c:cs) = replStr (show c) <> "
" <> traceToStr cs - -repl :: Char -> String -repl '<' = "<" -repl '+' = "+" -repl '|' = "|" -repl c = [c] - -replStr :: String -> String -replStr = concatMap repl main :: IO () main = do diff --git a/web-app/StringFormat.hs b/web-app/StringFormat.hs new file mode 100644 index 0000000..13aa01e --- /dev/null +++ b/web-app/StringFormat.hs @@ -0,0 +1,26 @@ +module StringFormat where + +import Environment +import Common +import Syntax.Typed.Terms +import Pretty.Typed () + +import Data.List (intercalate) + +envToStr :: Environment -> String +envToStr env = do + let tys = getTypes (MkModule "") env + let tyStrs = (\(nm,ty) -> replStr (show nm) <> "::" <> replStr (show ty)) <$> tys + intercalate "
" tyStrs + +traceToStr :: [Command] -> String +traceToStr cmds = intercalate "
" (replStr . show <$> cmds) + +repl :: Char -> String +repl '<' = "<" +repl '+' = "+" +repl '|' = "|" +repl c = [c] + +replStr :: String -> String +replStr = concatMap repl diff --git a/web-app/index.html b/web-app/index.html index aa7b98a..27e5986 100644 --- a/web-app/index.html +++ b/web-app/index.html @@ -40,6 +40,8 @@

One Sided Sequent Calculus

Results

+ Types:
+
Trace: