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