hlinted
This commit is contained in:
parent
9076115af5
commit
212630f872
5 changed files with 90 additions and 84 deletions
7
Notes.org
Normal file
7
Notes.org
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
* Notes
|
||||||
|
|
||||||
|
** hlint
|
||||||
|
|
||||||
|
#+BEGIN_SRC
|
||||||
|
hlint . --report
|
||||||
|
#+END_SRC
|
|
@ -25,10 +25,10 @@ infer _ Void = return LVoid
|
||||||
infer _ (Num _) = return LNum
|
infer _ (Num _) = return LNum
|
||||||
infer _ (Bool _) = return LBool
|
infer _ (Bool _) = return LBool
|
||||||
infer _ (Str _) = return LStr
|
infer _ (Str _) = return LStr
|
||||||
infer ctx (List ((Fix expr):exprs)) = do
|
infer ctx (List (Fix expr:exprs)) =
|
||||||
case infer ctx expr of
|
case infer ctx expr of
|
||||||
Left terr -> Left terr
|
Left terr -> Left terr
|
||||||
Right t -> case mapM (\e -> checkType ctx e t) (map unFix exprs) of
|
Right t -> case traverse ((\e -> checkType ctx e t) . unFix) exprs of
|
||||||
Left terror -> Left terror
|
Left terror -> Left terror
|
||||||
Right _ -> return $ LList t
|
Right _ -> return $ LList t
|
||||||
infer ctx (Atom a) = case Map.lookup a ctx of
|
infer ctx (Atom a) = case Map.lookup a ctx of
|
||||||
|
@ -38,11 +38,11 @@ infer ctx (Fn parameters fnbody _ (ptypes,retType)) = do
|
||||||
let newCtx = Map.union ctx (Map.fromList (zip parameters ptypes))
|
let newCtx = Map.union ctx (Map.fromList (zip parameters ptypes))
|
||||||
checkType newCtx (unFix fnbody) retType
|
checkType newCtx (unFix fnbody) retType
|
||||||
return $ LFn ptypes retType
|
return $ LFn ptypes retType
|
||||||
infer ctx (Lambda ((Fix (Fn fnparams _ _ (ptypes,retType))):exprs)) =
|
infer ctx (Lambda (Fix (Fn fnparams _ _ (ptypes,retType)):exprs)) =
|
||||||
if length fnparams /= length exprs
|
if length fnparams /= length exprs
|
||||||
then Left (TypeError "Fn applied to the wrong number of parameters")
|
then Left (TypeError "Fn applied to the wrong number of parameters")
|
||||||
else do
|
else do
|
||||||
inferedTypes <- mapM (infer ctx) (map unFix exprs)
|
inferedTypes <- traverse (infer ctx . unFix) exprs
|
||||||
if inferedTypes /= ptypes
|
if inferedTypes /= ptypes
|
||||||
then Left . TypeError $ "Expected " <> show ptypes
|
then Left . TypeError $ "Expected " <> show ptypes
|
||||||
<> " bug got " <> show inferedTypes
|
<> " bug got " <> show inferedTypes
|
||||||
|
@ -53,10 +53,9 @@ infer _ sexp = Left . TypeError $ "can't infer the type of " <> show sexp
|
||||||
-- | Check the type of some expression regarding a type context
|
-- | Check the type of some expression regarding a type context
|
||||||
checkType :: Context -> SExp -> LishType -> Either TypeError ()
|
checkType :: Context -> SExp -> LishType -> Either TypeError ()
|
||||||
checkType ctx expr ty = infer ctx expr >>= \ inferedType ->
|
checkType ctx expr ty = infer ctx expr >>= \ inferedType ->
|
||||||
if inferedType == ty
|
unless (inferedType == ty) $
|
||||||
then return ()
|
Left (TypeError ("Expected Type" <> show ty
|
||||||
else Left (TypeError ("Expected Type" <> show ty
|
<> " but got type " <> show inferedType))
|
||||||
<> " but got type " <> show inferedType))
|
|
||||||
|
|
||||||
isReduced :: SExp -> Bool
|
isReduced :: SExp -> Bool
|
||||||
isReduced (Atom _) = False
|
isReduced (Atom _) = False
|
||||||
|
@ -71,10 +70,10 @@ _reduceLambda (Lambda (Fix expr:fexprs)) = do
|
||||||
let exprs = map unFix fexprs
|
let exprs = map unFix fexprs
|
||||||
reduced <- reduceLambda expr
|
reduced <- reduceLambda expr
|
||||||
if isReduced reduced
|
if isReduced reduced
|
||||||
then do
|
then
|
||||||
case reduced of
|
case reduced of
|
||||||
Internal command -> (_commandFn command) reduceLambda exprs
|
Internal command -> _commandFn command reduceLambda exprs
|
||||||
f@(Fn _ _ _ _) -> applyFn f exprs
|
f@Fn{} -> applyFn f exprs
|
||||||
s -> do
|
s -> do
|
||||||
reducedArgs <- mapM reduceLambda exprs
|
reducedArgs <- mapM reduceLambda exprs
|
||||||
executeCommand (Cmd (Fix s) (map Fix reducedArgs))
|
executeCommand (Cmd (Fix s) (map Fix reducedArgs))
|
||||||
|
@ -92,7 +91,7 @@ _reduceLambda x = return x
|
||||||
reduceLambda :: SExp -> StateT Env IO SExp
|
reduceLambda :: SExp -> StateT Env IO SExp
|
||||||
reduceLambda x = do
|
reduceLambda x = do
|
||||||
env <- get
|
env <- get
|
||||||
case (Map.lookup "LISH_DEBUG" env) of
|
case Map.lookup "LISH_DEBUG" env of
|
||||||
Just (Str "true") -> liftIO $ do
|
Just (Str "true") -> liftIO $ do
|
||||||
putText "------"
|
putText "------"
|
||||||
putStr ("Env: " :: Text)
|
putStr ("Env: " :: Text)
|
||||||
|
@ -131,12 +130,12 @@ shellErr errmsg = do
|
||||||
-- | Execute a shell command
|
-- | Execute a shell command
|
||||||
executeCommand :: SExp -> StateT Env IO SExp
|
executeCommand :: SExp -> StateT Env IO SExp
|
||||||
executeCommand (Cmd (Fix (Str cmdName)) args) = do
|
executeCommand (Cmd (Fix (Str cmdName)) args) = do
|
||||||
res <- (mapM toArg (map unFix args)) >>= return . catMaybes
|
res <- fmap catMaybes (traverse toArg (map unFix args))
|
||||||
let argsHandle = (filter isJust (map toStdIn (map unFix args)))
|
let argsHandle = filter isJust (map (toStdIn . unFix) args)
|
||||||
stdinhandle = case argsHandle of
|
stdinhandle = case argsHandle of
|
||||||
(Just h:_) -> UseHandle h
|
(Just h:_) -> UseHandle h
|
||||||
_ -> Inherit
|
_ -> Inherit
|
||||||
case (map toS res) of
|
case map toS res of
|
||||||
sargs -> do
|
sargs -> do
|
||||||
result <- lift . trySh $
|
result <- lift . trySh $
|
||||||
createProcess (proc (toS cmdName) sargs)
|
createProcess (proc (toS cmdName) sargs)
|
||||||
|
|
|
@ -28,14 +28,14 @@ toArg (Num i) = return . Just . toS . show $ i
|
||||||
toArg (Stream (Just h)) = lift $ fmap (Just . Text.strip .toS) (hGetContents h)
|
toArg (Stream (Just h)) = lift $ fmap (Just . Text.strip .toS) (hGetContents h)
|
||||||
toArg (List xs) = do
|
toArg (List xs) = do
|
||||||
strs <- traverse toArg (map unFix xs)
|
strs <- traverse toArg (map unFix xs)
|
||||||
return (Just ("["<> (Text.intercalate " " (catMaybes strs)) <> "]"))
|
return (Just ("["<> Text.intercalate " " (catMaybes strs) <> "]"))
|
||||||
toArg _ = return $ Nothing
|
toArg _ = return Nothing
|
||||||
|
|
||||||
-- | Print with return line
|
-- | Print with return line
|
||||||
prn :: ReduceUnawareCommand
|
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
|
||||||
|
@ -52,14 +52,14 @@ evalErr errmsg = do
|
||||||
|
|
||||||
-- | Undefine a var
|
-- | Undefine a var
|
||||||
undef :: ReduceUnawareCommand
|
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)
|
||||||
|
|
||||||
-- | replace à la `sed s/old/new/g text`
|
-- | replace à la `sed s/old/new/g text`
|
||||||
replace :: ReduceUnawareCommand
|
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"
|
||||||
|
|
||||||
|
@ -71,31 +71,31 @@ str exprs = do
|
||||||
|
|
||||||
-- | create an atom from a string (do nothing to atoms)
|
-- | create an atom from a string (do nothing to atoms)
|
||||||
atom :: ReduceUnawareCommand
|
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) -> ReduceUnawareCommand
|
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 _ exprs = evalErr
|
binop _ exprs = evalErr
|
||||||
("binary operator needs two numbers. Got: " <> toS (show exprs))
|
("binary operator needs two numbers. Got: " <> toS (show exprs))
|
||||||
|
|
||||||
bbinop :: (Bool -> Bool -> Bool) -> ReduceUnawareCommand
|
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 :: ReduceUnawareCommand
|
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 :: ReduceUnawareCommand
|
toWaitingStream :: ReduceUnawareCommand
|
||||||
toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
|
toWaitingStream [Stream (Just h) ] = return (WaitingStream (Just h))
|
||||||
toWaitingStream _ = return Void
|
toWaitingStream _ = return Void
|
||||||
|
|
||||||
bintest :: (Integer -> Integer -> Bool) -> ReduceUnawareCommand
|
bintest :: (Integer -> Integer -> Bool) -> ReduceUnawareCommand
|
||||||
bintest f ((Num x):(Num y):[]) = return $ Bool (f x y)
|
bintest f [Num x,Num y] = return $ Bool (f x y)
|
||||||
bintest _ args = evalErr $ "bin test need two numbers got " <> (toS (show args))
|
bintest _ args = evalErr $ "bin test need two numbers got " <> toS (show args)
|
||||||
|
|
||||||
isReduced :: SExp -> Bool
|
isReduced :: SExp -> Bool
|
||||||
isReduced (Atom _) = False
|
isReduced (Atom _) = False
|
||||||
|
@ -124,11 +124,11 @@ fn reducer (p:bodies) = do
|
||||||
List args -> do
|
List args -> do
|
||||||
let parameters = map fromAtom args
|
let parameters = map fromAtom args
|
||||||
if all isJust parameters
|
if all isJust parameters
|
||||||
then return (Fn { params = catMaybes parameters
|
then return Fn { params = catMaybes parameters
|
||||||
, body = Fix . Lambda . map Fix $ (Atom "do"):bodies
|
, body = Fix . Lambda . map Fix $ Atom "do":bodies
|
||||||
, closure = mempty
|
, closure = mempty
|
||||||
, types = ([],LCommand)
|
, types = ([],LCommand)
|
||||||
})
|
}
|
||||||
else return Void
|
else return Void
|
||||||
_ -> return Void
|
_ -> return Void
|
||||||
where fromAtom (Fix (Atom a)) = Just a
|
where fromAtom (Fix (Atom a)) = Just a
|
||||||
|
@ -162,7 +162,7 @@ strictCommands = [ ("prn", prn)
|
||||||
|
|
||||||
-- | Define a var
|
-- | Define a var
|
||||||
def :: Command
|
def :: Command
|
||||||
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 _ exprs =
|
def _ exprs =
|
||||||
|
@ -173,11 +173,11 @@ doCommand :: Command
|
||||||
doCommand reduceLambda (expr:nexpr:exprs) = do
|
doCommand reduceLambda (expr:nexpr:exprs) = do
|
||||||
_ <- reduceLambda expr
|
_ <- reduceLambda expr
|
||||||
doCommand reduceLambda (nexpr:exprs)
|
doCommand reduceLambda (nexpr:exprs)
|
||||||
doCommand reduceLambda (expr:[]) = reduceLambda expr
|
doCommand reduceLambda [expr] = reduceLambda expr
|
||||||
doCommand _ _ = return Void
|
doCommand _ _ = return Void
|
||||||
|
|
||||||
lishIf :: Command
|
lishIf :: Command
|
||||||
lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
|
lishIf reduceLambda [sexp,sexp1,sexp2] = do
|
||||||
reducedSexp <- reduceLambda sexp
|
reducedSexp <- reduceLambda sexp
|
||||||
case reducedSexp of
|
case reducedSexp of
|
||||||
Bool True -> reduceLambda sexp1
|
Bool True -> reduceLambda sexp1
|
||||||
|
@ -186,92 +186,92 @@ lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
|
||||||
lishIf _ _ = evalErr "if need a bool, a then body and an else one"
|
lishIf _ _ = evalErr "if need a bool, a then body and an else one"
|
||||||
|
|
||||||
emptyCmd :: Command
|
emptyCmd :: Command
|
||||||
emptyCmd _ ((List []):[]) = return (Bool True)
|
emptyCmd _ [List []] = return (Bool True)
|
||||||
emptyCmd _ ((List _):[]) = return (Bool False)
|
emptyCmd _ [List _] = return (Bool False)
|
||||||
emptyCmd r (x@(Atom _):[]) = do
|
emptyCmd r [x@(Atom _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
emptyCmd r (val:[])
|
emptyCmd r [val]
|
||||||
emptyCmd r (x@(Lambda _):[]) = do
|
emptyCmd r [x@(Lambda _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
emptyCmd r (val:[])
|
emptyCmd r [val]
|
||||||
emptyCmd _ _ = return Void
|
emptyCmd _ _ = return Void
|
||||||
|
|
||||||
firstCmd :: Command
|
firstCmd :: Command
|
||||||
firstCmd reducer ((List (x:_)):[]) = reducer (unFix x)
|
firstCmd reducer [List (x:_)] = reducer (unFix x)
|
||||||
firstCmd _ ((List _):[]) = return Void
|
firstCmd _ [List _] = return Void
|
||||||
firstCmd r (x@(Atom _):[]) = do
|
firstCmd r [x@(Atom _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
firstCmd r (val:[])
|
firstCmd r [val]
|
||||||
firstCmd r (x@(Lambda _):[]) = do
|
firstCmd r [x@(Lambda _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
firstCmd r (val:[])
|
firstCmd r [val]
|
||||||
firstCmd _ _ = return Void
|
firstCmd _ _ = return Void
|
||||||
|
|
||||||
restCmd :: Command
|
restCmd :: Command
|
||||||
restCmd _ ((List (_:xs)):[]) = return (List xs)
|
restCmd _ [List (_:xs)] = return (List xs)
|
||||||
restCmd _ ((List _):[]) = return Void
|
restCmd _ [List _] = return Void
|
||||||
restCmd r (x@(Atom _):[]) = do
|
restCmd r [x@(Atom _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
restCmd r (val:[])
|
restCmd r [val]
|
||||||
restCmd r (x@(Lambda _):[]) = do
|
restCmd r [x@(Lambda _)] = do
|
||||||
val <- r x
|
val <- r x
|
||||||
restCmd r (val:[])
|
restCmd r [val]
|
||||||
restCmd _ _ = return Void
|
restCmd _ _ = return Void
|
||||||
|
|
||||||
consCmd :: Command
|
consCmd :: Command
|
||||||
consCmd r (x:(List ls):[]) = do
|
consCmd r [x,List ls] = do
|
||||||
xreduced <- r x
|
xreduced <- r x
|
||||||
return (List (Fix xreduced:ls))
|
return (List (Fix xreduced:ls))
|
||||||
consCmd r (x:y@(Atom _):[]) = do
|
consCmd r [x,y@(Atom _)] = do
|
||||||
val <- r y
|
val <- r y
|
||||||
consCmd r (x:val:[])
|
consCmd r [x,val]
|
||||||
consCmd r (x:y@(Lambda _):[]) = do
|
consCmd r [x,y@(Lambda _)] = do
|
||||||
val <- r y
|
val <- r y
|
||||||
consCmd r (x:val:[])
|
consCmd r [x,val]
|
||||||
consCmd _ _ = return Void
|
consCmd _ _ = return Void
|
||||||
|
|
||||||
equal :: Command
|
equal :: Command
|
||||||
equal r ((List xs):(List ys):[]) = do
|
equal r [List xs,List ys] = do
|
||||||
reducedListX <- traverse r (map unFix xs)
|
reducedListX <- traverse r (map unFix xs)
|
||||||
reducedListY <- traverse r (map unFix ys)
|
reducedListY <- traverse r (map unFix ys)
|
||||||
return (Bool (reducedListX == reducedListY))
|
return (Bool (reducedListX == reducedListY))
|
||||||
equal r (x:y:[]) = do
|
equal r [x,y] = do
|
||||||
reducedX <- r x
|
reducedX <- r x
|
||||||
reducedY <- r y
|
reducedY <- r y
|
||||||
return (Bool (reducedX == reducedY))
|
return (Bool (reducedX == reducedY))
|
||||||
equal _ args = evalErr $ "= need two args, got " <> (toS (show args))
|
equal _ args = evalErr $ "= need two args, got " <> toS (show args)
|
||||||
|
|
||||||
-- | Export a var as Environment variable
|
-- | Export a var as Environment variable
|
||||||
export :: Command
|
export :: Command
|
||||||
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)
|
||||||
return v
|
return v
|
||||||
export r (n:value:[]) = do
|
export r [n,value] = do
|
||||||
reducedVal <- r value
|
reducedVal <- r value
|
||||||
export r (n:reducedVal:[])
|
export r [n,reducedVal]
|
||||||
export _ _ = evalErr $ "eval need an atom and a string (eval foo \"foo\")"
|
export _ _ = evalErr "eval need an atom and a string (eval foo \"foo\")"
|
||||||
|
|
||||||
evalStr :: Command
|
evalStr :: Command
|
||||||
evalStr r ((Str program):[]) = do
|
evalStr r [Str program] = do
|
||||||
let parsed = parseCmd program
|
let parsed = parseCmd program
|
||||||
case parsed of
|
case parsed of
|
||||||
Right expr -> r (unFix expr)
|
Right expr -> r (unFix expr)
|
||||||
_ -> evalErr "evalStr error"
|
_ -> evalErr "evalStr error"
|
||||||
evalStr r (x@(Atom _):[]) = do
|
evalStr r [x@(Atom _)] = do
|
||||||
reduced <- r x
|
reduced <- r x
|
||||||
evalStr r (reduced:[])
|
evalStr r [reduced]
|
||||||
evalStr r (x@(Lambda _):[]) = do
|
evalStr r [x@(Lambda _)] = do
|
||||||
reduced <- r x
|
reduced <- r x
|
||||||
evalStr r (reduced:[])
|
evalStr r [reduced]
|
||||||
evalStr _ _ = evalErr "evalStr error"
|
evalStr _ _ = evalErr "evalStr error"
|
||||||
|
|
||||||
-- | retrieve the value of a var
|
-- | retrieve the value of a var
|
||||||
getenv :: Command
|
getenv :: Command
|
||||||
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 _ ((Str varname):[]) = do
|
getenv _ [Str varname] = do
|
||||||
hm <- get
|
hm <- get
|
||||||
return $ fromMaybe Void (Map.lookup varname hm)
|
return $ fromMaybe Void (Map.lookup varname hm)
|
||||||
getenv r (expr:_) = do
|
getenv r (expr:_) = do
|
||||||
|
@ -289,11 +289,11 @@ quote :: Command
|
||||||
quote _ exprs = return (List (map Fix exprs))
|
quote _ exprs = return (List (map Fix exprs))
|
||||||
|
|
||||||
evalList :: Command
|
evalList :: Command
|
||||||
evalList r (List exprs:[]) = r (Lambda exprs)
|
evalList r [List exprs] = r (Lambda exprs)
|
||||||
evalList r (x@(Atom _):[]) = do
|
evalList r [x@(Atom _)] = do
|
||||||
evaluated <- r x
|
evaluated <- r x
|
||||||
evalList r [evaluated]
|
evalList r [evaluated]
|
||||||
evalList r (x@(Lambda _):[]) = do
|
evalList r [x@(Lambda _)] = do
|
||||||
evaluated <- r x
|
evaluated <- r x
|
||||||
evalList r [evaluated]
|
evalList r [evaluated]
|
||||||
evalList _ x = evalErr ("Waiting for a list of exprs got: " <> toS (show x))
|
evalList _ x = evalErr ("Waiting for a list of exprs got: " <> toS (show x))
|
||||||
|
|
|
@ -27,7 +27,7 @@ parseNumber = (Fix . Num . fromMaybe 0 . readMaybe) <$> many1 digit
|
||||||
|
|
||||||
parseAtom :: Parser Expr
|
parseAtom :: Parser Expr
|
||||||
parseAtom = do
|
parseAtom = do
|
||||||
frst <- (noneOf " \t()[]\"")
|
frst <- noneOf " \t()[]\""
|
||||||
rest <- many (noneOf " \t()[]")
|
rest <- many (noneOf " \t()[]")
|
||||||
case frst:rest of
|
case frst:rest of
|
||||||
"true" -> return . Fix $ Bool True
|
"true" -> return . Fix $ Bool True
|
||||||
|
|
|
@ -67,11 +67,11 @@ repr (Internal (InternalCommand n _)) = n
|
||||||
repr (Num n) = toS $ show n
|
repr (Num n) = toS $ show n
|
||||||
repr (Bool b) = if b then "true" else "false"
|
repr (Bool b) = if b then "true" else "false"
|
||||||
repr (Str s) = "\"" <> toS s <> "\""
|
repr (Str s) = "\"" <> toS s <> "\""
|
||||||
repr (List sexprs) = "[" <> (Text.intercalate " " sexprs) <> "]"
|
repr (List sexprs) = "[" <> Text.intercalate " " sexprs <> "]"
|
||||||
repr (Lambda sexprs) = "(" <> (Text.intercalate " " sexprs) <> ")"
|
repr (Lambda sexprs) = "(" <> Text.intercalate " " sexprs <> ")"
|
||||||
repr Void = "ε"
|
repr Void = "ε"
|
||||||
repr (Cmd n args) = "($ " <> n <> (Text.intercalate " " args) <> ")"
|
repr (Cmd n args) = "($ " <> n <> Text.intercalate " " args <> ")"
|
||||||
repr (Fn p _ _ _) = "(λ" <> (Text.intercalate "." p) <> ". ... )"
|
repr (Fn p _ _ _) = "(λ" <> Text.intercalate "." p <> ". ... )"
|
||||||
repr (Stream _) = "<stream>"
|
repr (Stream _) = "<stream>"
|
||||||
repr (WaitingStream _) = "<w-stream>"
|
repr (WaitingStream _) = "<w-stream>"
|
||||||
|
|
||||||
|
@ -88,4 +88,4 @@ data InternalCommand =
|
||||||
instance Show InternalCommand where
|
instance Show InternalCommand where
|
||||||
show x = toS (_commandName x)
|
show x = toS (_commandName x)
|
||||||
instance Eq InternalCommand where
|
instance Eq InternalCommand where
|
||||||
(==) x y = (_commandName x) == (_commandName y)
|
(==) x y = _commandName x == _commandName y
|
||||||
|
|
Loading…
Reference in a new issue