yogsototh/lish
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Strict functions fix

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2017-04-06 10:21:53 +02:00
parent 43ad544de9
commit d2ba02cdd9
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
6 changed files with 81 additions and 80 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lish.cabal
View file

@ -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
package.yaml
View file

@ -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

2
src/Lish/Core.hs
View file

@ -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

67
src/Lish/Eval.hs
View file

@ -65,45 +65,40 @@ 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
Atom f -> do
resultInternal <- tryInternalCommand f exprs
case resultInternal of
Just x -> return x
Nothing -> do
resultEnv <- tryEnvCommand f exprs
case resultEnv of
Just x -> return x
Nothing -> do
reducedArgs <- mapM reduceLambda exprs
executeCommand (Command (Fix (Str f))
(map Fix reducedArgs))
Internal command -> (_commandFn command) reduceLambda exprs
f@(Fn _ _ _ _) -> applyFn f exprs
s -> do
reducedArgs <- mapM reduceLambda exprs
executeCommand $ Command (Fix s) (map Fix reducedArgs)
executeCommand (Cmd (Fix s) (map Fix reducedArgs))
else reduceLambda (Lambda . map Fix $ (reduced:exprs))
reduceLambda command@(Command _ _) = 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
_ -> return $ Str x
reduceLambda x = return x
_ -> case InternalCommands.lookup x of
Just cmd -> return (Internal cmd)
_ -> return (Str 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 =
@ -114,25 +109,11 @@ 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
tryEnvCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
tryEnvCommand f args = do
envcmd <- get
case Map.lookup f envcmd of
Just fn@(Fn _ _ _ _) -> Just <$> (applyFn fn args)
_ -> return Nothing
tryInternalCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
tryInternalCommand f args =
case InternalCommands.lookup f of
Just (fn) -> Just <$> fn reduceLambda args
_ -> return Nothing
-- | take a SExp
toStdIn :: SExp -> Maybe Handle
toStdIn (WaitingStream h) = h
@ -145,7 +126,7 @@ shellErr errmsg = do
-- | Execute a shell command
executeCommand :: SExp -> StateT Env IO SExp
executeCommand (Command (Fix (Str cmdName)) args) = do
executeCommand (Cmd (Fix (Str cmdName)) args) = do
res <- (mapM toArg (map unFix args)) >>= return . catMaybes
let argsHandle = (filter isJust (map toStdIn (map unFix args)))
stdinhandle = case argsHandle of

40
src/Lish/InternalCommands.hs
View file

@ -11,10 +11,11 @@ import Data.Fix
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import GHC.IO.Handle (hGetContents)
import Lish.Types
import Protolude hiding (show)
import System.Environment (setEnv)
import Lish.Types
toArg :: SExp -> StateT Env IO (Maybe Text)
toArg (Atom x) = do
env <- get
@ -114,13 +115,22 @@ bintest :: (Integer -> Integer -> Bool) -> ReduceUnawareCommand
bintest f ((Num x):(Num y):[]) = return $ Bool (f x y)
bintest _ args = evalErr $ "bin test need two numbers got " <> (toS (show args))
isReduced :: SExp -> Bool
isReduced (Atom _) = False
isReduced (Lambda _) = False
isReduced _ = True
deepReduce :: (Monad m) => (SExp -> m SExp) -> SExp -> m SExp
deepReduce f x =
if isReduced x
then pure x
else do
reducedOnce <- f x
deepReduce f reducedOnce
toStrictCmd :: ReduceUnawareCommand -> Command
toStrictCmd f reducer sexps = do
reduced <- mapM reducer sexps
-- DEBUG -- liftIO $ putText "Reduced:"
-- DEBUG -- liftIO $ print reduced
-- DEBUG -- liftIO $ putText "----"
f reduced
toStrictCmd f reducer sexps =
f =<< mapM (deepReduce reducer) sexps
-- | fn to declare a lish function
-- (fn [arg1 arg2] body1 body2)
@ -194,17 +204,17 @@ lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
_ -> evalErr "first argument to if must be a Bool"
lishIf _ _ = evalErr "if need a bool, a then body and an else one"
unstrictCommands :: [(Text,Command)]
unstrictCommands = [ ("if",lishIf)
, ("def",def)
, ("fn",fn)
, ("do",doCommand)
unstrictCommands :: [(Text,InternalCommand)]
unstrictCommands = [ ("if", InternalCommand "if" lishIf)
, ("def", InternalCommand "def" def)
, ("fn", InternalCommand "fn" fn)
, ("do", InternalCommand "do" doCommand)
]
internalCommands :: Map.Map Text Command
internalCommands = (strictCommands & map (\(x,y) -> (x,toStrictCmd y)))
internalCommands :: Map.Map Text InternalCommand
internalCommands = (strictCommands & map (\(x,y) -> (x,InternalCommand x (toStrictCmd y))))
<> unstrictCommands
& Map.fromList
lookup :: Text -> Maybe Command
lookup :: Text -> Maybe InternalCommand
lookup = flip Map.lookup internalCommands

14
src/Lish/Types.hs
View file

@ -12,6 +12,7 @@ module Lish.Types
, Env
, CmdStream
, Command
, InternalCommand (..)
, ReduceUnawareCommand
-- types
, LishType(..)
@ -34,12 +35,13 @@ data ExprF a = Atom Text
| Lambda [a]
| Void
-- only exists during evaluation
| Internal InternalCommand
| Fn { params :: [Text]
, body :: a
, closure :: Env
, types :: ([LishType],LishType)
}
| Command { _cmdName :: a
| Cmd { _cmdName :: a
, _cmdArgs :: [a]}
| Stream CmdStream
| WaitingStream CmdStream
@ -61,13 +63,14 @@ type Context = Map Text LishType
repr :: ExprF Text -> Text
repr (Atom s) = s
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 <> "\""
repr (List sexprs) = "[" <> (Text.intercalate " " sexprs) <> "]"
repr (Lambda sexprs) = "(" <> (Text.intercalate " " sexprs) <> ")"
repr Void = "ε"
repr (Command n args) = "($ " <> n <> (Text.intercalate " " args) <> ")"
repr (Cmd n args) = "($ " <> n <> (Text.intercalate " " args) <> ")"
repr (Fn p _ _ _) = "(λ" <> (Text.intercalate "." p) <> ". ... )"
repr (Stream _) = "<stream>"
repr (WaitingStream _) = "<w-stream>"
@ -79,3 +82,10 @@ type CmdStream = Maybe Handle
type Env = Map Text SExp
type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp
type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand
data InternalCommand =
InternalCommand { _commandName :: Text
, _commandFn :: Command }
instance Show InternalCommand where
show x = toS (_commandName x)
instance Eq InternalCommand where
(==) x y = (_commandName x) == (_commandName y)