Compare commits

...

2 Commits

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

@ -7,20 +7,21 @@ module Lish.InternalCommands
)
where
import Data.Fix
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
return $ Just $ case Map.lookup x env of
Just (Str s) -> s
_ -> toS x
_ -> toS x
toArg (Str s) = return $ Just $ toS s
toArg (Num i) = return . Just . toS . show $ i
toArg (Stream (Just h)) = lift $ fmap (Just . Text.strip .toS) (hGetContents h)
@ -100,7 +101,7 @@ bbinop _ _ = evalErr "boolean binary operator need two booleans arguments"
lnot :: ReduceUnawareCommand
lnot ((Bool x):[]) = return ( Bool (not x))
lnot _ = evalErr "not need a boolean"
lnot _ = evalErr "not need a boolean"
toWaitingStream :: ReduceUnawareCommand
toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
@ -108,19 +109,28 @@ toWaitingStream _ = return Void
equal :: ReduceUnawareCommand
equal (x:y:[]) = return (Bool (x == y))
equal args = evalErr $ "= need two args, got " <> (toS (show args))
equal args = evalErr $ "= need two args, got " <> (toS (show args))
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)
@ -140,7 +150,7 @@ fn reducer (p:bodies) = do
else return Void
_ -> return Void
where fromAtom (Fix (Atom a)) = Just a
fromAtom _ = Nothing
fromAtom _ = Nothing
fn _ _ = return Void
strictCommands :: [(Text,ReduceUnawareCommand)]
@ -189,22 +199,22 @@ lishIf :: Command
lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
reducedSexp <- reduceLambda sexp
case reducedSexp of
Bool True -> reduceLambda sexp1
Bool True -> reduceLambda sexp1
Bool False -> reduceLambda sexp2
_ -> evalErr "first argument to if must be a Bool"
_ -> 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

@ -12,6 +12,7 @@ module Lish.Types
, Env
, CmdStream
, Command
, InternalCommand (..)
, ReduceUnawareCommand
-- types
, LishType(..)
@ -34,16 +35,17 @@ 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
, _cmdArgs :: [a]}
| Cmd { _cmdName :: a
, _cmdArgs :: [a]}
| Stream CmdStream
| WaitingStream CmdStream
deriving (Eq,Show,Functor)
deriving (Eq, Show, Functor)
type Expr = Fix ExprF
type SExp = ExprF Expr
@ -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)

Loading…
Cancel
Save