fix non recursive fns

wip
parent 15a6469729
commit 33af5f1a6d
Signed by: yogsototh
GPG Key ID: 7B19A4C650D59646

@ -26,7 +26,7 @@ source-repository head
library
hs-source-dirs:
src
ghc-options: -Wall -Werror -O2
ghc-options: -Wall -O2
build-depends:
base >= 4.8 && < 5
, containers
@ -52,7 +52,7 @@ executable lish
main-is: Main.hs
hs-source-dirs:
src-exe
ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >= 4.8 && < 5
, containers
@ -71,7 +71,7 @@ test-suite lish-benchmark
main-is: Main.hs
hs-source-dirs:
src-benchmark
ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >= 4.8 && < 5
, containers
@ -92,7 +92,7 @@ test-suite lish-doctest
main-is: Main.hs
hs-source-dirs:
src-doctest
ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >= 4.8 && < 5
, containers
@ -115,7 +115,7 @@ test-suite lish-test
main-is: Main.hs
hs-source-dirs:
src-test
ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >= 4.8 && < 5
, containers

@ -10,7 +10,7 @@ extra-source-files:
- README.md
- stack.yaml
ghc-options: -Wall -Werror -O2
ghc-options: -Wall -O2
dependencies:
- base >= 4.8 && < 5
@ -28,7 +28,7 @@ library:
executables:
lish:
ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N
main: Main.hs
source-dirs: src-exe
dependencies:
@ -38,7 +38,7 @@ tests:
lish-test:
source-dirs: src-test
main: Main.hs
ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N
dependencies:
- lish
- base >= 4.8 && < 5
@ -50,7 +50,7 @@ tests:
lish-doctest:
source-dirs: src-doctest
main: Main.hs
ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N
dependencies:
- lish
- base >= 4.8 && < 5
@ -60,7 +60,7 @@ tests:
lish-benchmark:
source-dirs: src-benchmark
main: Main.hs
ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
ghc-options: -threaded -rtsopts -with-rtsopts=-N
dependencies:
- lish
- base >= 4.8 && < 5

@ -26,7 +26,7 @@ runLish :: IO ()
runLish = do
env <- toEnv <$> getEnvironment
runInputT (defaultSettings { historyFile = Just ".lish-history" })
(mainLoop Nothing env "")
(mainLoop Nothing mempty "")
-- | System Environment -> LISH Env
toEnv :: [(String,String)] -> Env

@ -65,20 +65,12 @@ isReduced _ = True
-- | The main evaluation function
-- its real type should be something isomorphic to
-- (SExp,Environment) -> IO (SExp, Environment)
reduceLambda :: SExp -> StateT Env IO SExp
reduceLambda (Lambda (Fix expr:fexprs)) = do
_reduceLambda :: SExp -> StateT Env IO SExp
_reduceLambda (Lambda (Fix expr:fexprs)) = do
let exprs = map unFix fexprs
reduced <- reduceLambda expr
if isReduced reduced
then do
-- DEBUG --env <- get
-- DEBUG --liftIO $ do
-- DEBUG -- putText "Lambda:"
-- DEBUG -- print $ (expr:exprs)
-- DEBUG -- putText "Env:"
-- DEBUG -- print env
-- DEBUG -- putText "Reduced Head:"
-- DEBUG -- print reduced
case reduced of
Internal command -> (_commandFn command) reduceLambda exprs
f@(Fn _ _ _ _) -> applyFn f exprs
@ -86,15 +78,27 @@ reduceLambda (Lambda (Fix expr:fexprs)) = do
reducedArgs <- mapM reduceLambda exprs
executeCommand (Cmd (Fix s) (map Fix reducedArgs))
else reduceLambda (Lambda . map Fix $ (reduced:exprs))
reduceLambda command@(Internal _) = executeCommand command
reduceLambda (Atom x) = do
_reduceLambda command@(Internal _) = executeCommand command
_reduceLambda (Atom x) = do
env <- get
case Map.lookup x env of
Just s -> return s
_ -> case InternalCommands.lookup x of
Just cmd -> return (Internal cmd)
_ -> return (Str x)
reduceLambda x = return x
_reduceLambda x = return x
reduceLambda :: SExp -> StateT Env IO SExp
reduceLambda x = do
-- DEBUG --env <- get
-- DEBUG --liftIO $ do
-- DEBUG -- putText "------"
-- DEBUG -- putStr ("Env: " :: Text)
-- DEBUG -- print env
-- DEBUG -- putStr ("Arg: " :: Text)
-- DEBUG -- putStrLn $ pprint (Fix x)
_reduceLambda x
applyFn :: SExp -> ReduceUnawareCommand
applyFn (Fn par bod clos _) args =
@ -105,7 +109,7 @@ applyFn (Fn par bod clos _) args =
currentEnv <- get
-- Run the function in its own closure
fmap fst $ liftIO $
runStateT (reduceLambda (unFix bod)) (Map.union currentEnv localClosure)
runStateT (reduceLambda (unFix bod)) (Map.union localClosure currentEnv)
where
bindVars oldenv newvars = Map.union oldenv (Map.fromList newvars)
applyFn x _ = return x

@ -129,12 +129,8 @@ deepReduce f x =
deepReduce f reducedOnce
toStrictCmd :: ReduceUnawareCommand -> Command
toStrictCmd f reducer sexps = do
reduced <- mapM (deepReduce reducer) sexps
liftIO $ putText "Reduced:"
liftIO $ print reduced
liftIO $ putText "----"
f reduced
toStrictCmd f reducer sexps =
f =<< mapM (deepReduce reducer) sexps
-- | fn to declare a lish function
-- (fn [arg1 arg2] body1 body2)

@ -63,7 +63,7 @@ type Context = Map Text LishType
repr :: ExprF Text -> Text
repr (Atom s) = s
repr (Internal _) = "<int-cmd>"
repr (Internal (InternalCommand n _)) = n
repr (Num n) = toS $ show n
repr (Bool b) = if b then "true" else "false"
repr (Str s) = "\"" <> toS s <> "\""

Loading…
Cancel
Save