added strict and non stric internals
This commit is contained in:
parent
d7feabece0
commit
ae2559c5b4
3 changed files with 54 additions and 26 deletions
|
@ -19,22 +19,26 @@ import Lish.Types hiding (show)
|
|||
-- TODO: its real type should be something isomorphic to
|
||||
-- (SExp,Environment) -> IO (SExp, Environment)
|
||||
reduceLambda :: SExp -> StateT Env IO SExp
|
||||
reduceLambda (Lambda exprs) = do
|
||||
reduced <- mapM reduceLambda exprs
|
||||
reduceLambda (Lambda (expr:exprs)) = do
|
||||
reduced <- reduceLambda expr
|
||||
case reduced of
|
||||
(Atom f:args) -> do
|
||||
resultInternal <- tryInternalCommand f args
|
||||
Atom f -> do
|
||||
resultInternal <- tryInternalCommand f exprs
|
||||
case resultInternal of
|
||||
Just x -> return x
|
||||
Nothing -> do
|
||||
resultEnv <- tryEnvCommand f args
|
||||
resultEnv <- tryEnvCommand f exprs
|
||||
case resultEnv of
|
||||
Just x -> return x
|
||||
Nothing -> executeShell (Lambda reduced)
|
||||
_ -> executeShell (Lambda reduced)
|
||||
Nothing -> do
|
||||
reducedArgs <- mapM reduceLambda exprs
|
||||
executeShell (Lambda ((Atom f):reducedArgs))
|
||||
s -> do
|
||||
reducedArgs <- mapM reduceLambda exprs
|
||||
executeShell (Lambda (s:reducedArgs))
|
||||
reduceLambda x = return x
|
||||
|
||||
apply :: SExp -> Command
|
||||
apply :: SExp -> ReduceUnawareCommand
|
||||
apply x _ = return x
|
||||
|
||||
tryEnvCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
|
||||
|
@ -48,7 +52,7 @@ tryEnvCommand f args = do
|
|||
tryInternalCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
|
||||
tryInternalCommand f args =
|
||||
case InternalCommands.lookup f of
|
||||
Just fn -> Just <$> fn args
|
||||
Just (fn) -> Just <$> fn reduceLambda args
|
||||
_ -> return Nothing
|
||||
|
||||
-- | take a SExp
|
||||
|
|
|
@ -25,14 +25,14 @@ toArg (Stream (Just h)) = lift $ fmap (Just . Text.strip .toS) (hGetContents h)
|
|||
toArg _ = return $ Nothing
|
||||
|
||||
-- | Print with return line
|
||||
prn :: Command
|
||||
prn :: ReduceUnawareCommand
|
||||
prn args = do
|
||||
strs <- catMaybes <$> mapM toArg args
|
||||
putStrLn $ (Text.intercalate " " strs)
|
||||
return Void
|
||||
|
||||
-- | Print
|
||||
pr :: Command
|
||||
pr :: ReduceUnawareCommand
|
||||
pr args = do
|
||||
strs <- catMaybes <$> mapM toArg args
|
||||
putStr (Text.intercalate " " strs)
|
||||
|
@ -44,21 +44,21 @@ evalErr errmsg = do
|
|||
return Void
|
||||
|
||||
-- | Define a var
|
||||
def :: Command
|
||||
def :: ReduceUnawareCommand
|
||||
def ((Atom name):v:[]) = do
|
||||
modify (Map.insert name v)
|
||||
return v
|
||||
def _ = evalErr "def need 2 args, an atom and an S-Expr. Ex: (def foo \"foo\")"
|
||||
|
||||
-- | Undefine a var
|
||||
undef :: Command
|
||||
undef :: ReduceUnawareCommand
|
||||
undef ((Atom name):[]) = do
|
||||
modify (Map.delete name)
|
||||
return Void
|
||||
undef x = evalErr $ "undef wait an atom got" <> toS (show x)
|
||||
|
||||
-- | Export a var as Environment variable
|
||||
export :: Command
|
||||
export :: ReduceUnawareCommand
|
||||
export ((Atom name):v@(Str s):[]) = do
|
||||
liftIO $ setEnv (toS name) (toS s)
|
||||
modify (Map.insert name v)
|
||||
|
@ -66,49 +66,54 @@ export ((Atom name):v@(Str s):[]) = do
|
|||
export _ = evalErr $ "eval need an atom and a string (eval foo \"foo\")"
|
||||
|
||||
-- | retrieve the value of a var
|
||||
getenv :: Command
|
||||
getenv :: ReduceUnawareCommand
|
||||
getenv ((Atom varname):[]) = do
|
||||
hm <- get
|
||||
return $ fromMaybe Void (Map.lookup varname hm)
|
||||
getenv _ = evalErr "getenv need on atom as argument"
|
||||
|
||||
-- | replace à la `sed s/old/new/g text`
|
||||
replace :: Command
|
||||
replace :: ReduceUnawareCommand
|
||||
replace ((Str old) : (Str new) : (Str text) : []) =
|
||||
return $ Str $ Text.replace old new text
|
||||
replace _ = evalErr "replace should take 3 String arguments"
|
||||
|
||||
-- | create a string and concat multiple elements
|
||||
str :: Command
|
||||
str :: ReduceUnawareCommand
|
||||
str exprs = do
|
||||
args <- catMaybes <$> mapM toArg exprs
|
||||
return $ Str $ Text.concat args
|
||||
|
||||
-- | create an atom from a string (do nothing to atoms)
|
||||
atom :: Command
|
||||
atom :: ReduceUnawareCommand
|
||||
atom ((Atom a):[]) = return $ Atom a
|
||||
atom ((Str s):[]) = return $ Atom s
|
||||
atom _ = evalErr "atom need an atom or a string"
|
||||
|
||||
-- | Numbers Ops
|
||||
binop :: (Integer -> Integer -> Integer) -> Command
|
||||
binop :: (Integer -> Integer -> Integer) -> ReduceUnawareCommand
|
||||
binop f ((Num x):(Num y):[]) = return $ Num (f x y)
|
||||
binop _ _ = evalErr "binary operator needs two numbers"
|
||||
|
||||
bbinop :: (Bool -> Bool -> Bool) -> Command
|
||||
bbinop :: (Bool -> Bool -> Bool) -> ReduceUnawareCommand
|
||||
bbinop f ((Bool x):(Bool y):[]) = return $ Bool (f x y)
|
||||
bbinop _ _ = evalErr "boolean binary operator need two booleans arguments"
|
||||
|
||||
lnot :: Command
|
||||
lnot :: ReduceUnawareCommand
|
||||
lnot ((Bool x):[]) = return ( Bool (not x))
|
||||
lnot _ = evalErr "not need a boolean"
|
||||
|
||||
toWaitingStream :: Command
|
||||
toWaitingStream :: ReduceUnawareCommand
|
||||
toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
|
||||
toWaitingStream _ = return Void
|
||||
|
||||
internalCommands :: Map.Map Text Command
|
||||
internalCommands = [ ("prn", prn)
|
||||
toStrictCmd :: ReduceUnawareCommand -> Command
|
||||
toStrictCmd f reducer sexps = do
|
||||
reduced <- mapM reducer sexps
|
||||
f reduced
|
||||
|
||||
strictCommands :: [(Text,ReduceUnawareCommand)]
|
||||
strictCommands = [ ("prn", prn)
|
||||
, ("pr", pr)
|
||||
, (">", toWaitingStream)
|
||||
, ("replace", replace)
|
||||
|
@ -129,7 +134,24 @@ internalCommands = [ ("prn", prn)
|
|||
, ("and", bbinop (&&))
|
||||
, ("or", bbinop (||))
|
||||
, ("not", lnot)
|
||||
] & Map.fromList
|
||||
]
|
||||
|
||||
lishIf :: Command
|
||||
lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
|
||||
reducedSexp <- reduceLambda sexp
|
||||
case reducedSexp of
|
||||
Bool True -> reduceLambda sexp1
|
||||
Bool False -> reduceLambda sexp2
|
||||
_ -> 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)]
|
||||
|
||||
internalCommands :: Map.Map Text Command
|
||||
internalCommands = (strictCommands & map (\(x,y) -> (x,toStrictCmd y)))
|
||||
<> unstrictCommands
|
||||
& Map.fromList
|
||||
|
||||
lookup :: Text -> Maybe Command
|
||||
lookup = flip Map.lookup internalCommands
|
||||
|
|
|
@ -7,6 +7,7 @@ module Lish.Types
|
|||
, Env
|
||||
, CmdStream
|
||||
, Command
|
||||
, ReduceUnawareCommand
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -48,4 +49,5 @@ repr (WaitingStream _) = "<w-stream>"
|
|||
|
||||
type CmdStream = Maybe Handle
|
||||
type Env = Map.Map Text SExp
|
||||
type Command = [SExp] -> StateT Env IO SExp
|
||||
type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp
|
||||
type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand
|
||||
|
|
Loading…
Reference in a new issue