From 212630f872aba3bc557e08f80c2f3b35f0a4cd76 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Mon, 12 Jun 2017 09:29:22 +0200 Subject: [PATCH] hlinted --- Notes.org | 7 ++ src/Lish/Eval.hs | 29 ++++---- src/Lish/InternalCommands.hs | 126 +++++++++++++++++------------------ src/Lish/Parser.hs | 2 +- src/Lish/Types.hs | 10 +-- 5 files changed, 90 insertions(+), 84 deletions(-) create mode 100644 Notes.org diff --git a/Notes.org b/Notes.org new file mode 100644 index 0000000..be91576 --- /dev/null +++ b/Notes.org @@ -0,0 +1,7 @@ +* Notes + +** hlint + +#+BEGIN_SRC +hlint . --report +#+END_SRC diff --git a/src/Lish/Eval.hs b/src/Lish/Eval.hs index 7d7c9af..89d8f0c 100644 --- a/src/Lish/Eval.hs +++ b/src/Lish/Eval.hs @@ -25,10 +25,10 @@ infer _ Void = return LVoid infer _ (Num _) = return LNum infer _ (Bool _) = return LBool infer _ (Str _) = return LStr -infer ctx (List ((Fix expr):exprs)) = do +infer ctx (List (Fix expr:exprs)) = case infer ctx expr of 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 Right _ -> return $ LList t 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)) checkType newCtx (unFix fnbody) 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 then Left (TypeError "Fn applied to the wrong number of parameters") else do - inferedTypes <- mapM (infer ctx) (map unFix exprs) + inferedTypes <- traverse (infer ctx . unFix) exprs if inferedTypes /= ptypes then Left . TypeError $ "Expected " <> show ptypes <> " 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 checkType :: Context -> SExp -> LishType -> Either TypeError () checkType ctx expr ty = infer ctx expr >>= \ inferedType -> - if inferedType == ty - then return () - else Left (TypeError ("Expected Type" <> show ty - <> " but got type " <> show inferedType)) + unless (inferedType == ty) $ + Left (TypeError ("Expected Type" <> show ty + <> " but got type " <> show inferedType)) isReduced :: SExp -> Bool isReduced (Atom _) = False @@ -71,10 +70,10 @@ _reduceLambda (Lambda (Fix expr:fexprs)) = do let exprs = map unFix fexprs reduced <- reduceLambda expr if isReduced reduced - then do + then case reduced of - Internal command -> (_commandFn command) reduceLambda exprs - f@(Fn _ _ _ _) -> applyFn f exprs + Internal command -> _commandFn command reduceLambda exprs + f@Fn{} -> applyFn f exprs s -> do reducedArgs <- mapM reduceLambda exprs executeCommand (Cmd (Fix s) (map Fix reducedArgs)) @@ -92,7 +91,7 @@ _reduceLambda x = return x reduceLambda :: SExp -> StateT Env IO SExp reduceLambda x = do env <- get - case (Map.lookup "LISH_DEBUG" env) of + case Map.lookup "LISH_DEBUG" env of Just (Str "true") -> liftIO $ do putText "------" putStr ("Env: " :: Text) @@ -131,12 +130,12 @@ shellErr errmsg = do -- | Execute a shell command executeCommand :: SExp -> StateT Env IO SExp executeCommand (Cmd (Fix (Str cmdName)) args) = do - res <- (mapM toArg (map unFix args)) >>= return . catMaybes - let argsHandle = (filter isJust (map toStdIn (map unFix args))) + res <- fmap catMaybes (traverse toArg (map unFix args)) + let argsHandle = filter isJust (map (toStdIn . unFix) args) stdinhandle = case argsHandle of (Just h:_) -> UseHandle h _ -> Inherit - case (map toS res) of + case map toS res of sargs -> do result <- lift . trySh $ createProcess (proc (toS cmdName) sargs) diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs index 3b58204..55668dc 100644 --- a/src/Lish/InternalCommands.hs +++ b/src/Lish/InternalCommands.hs @@ -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 (List xs) = do strs <- traverse toArg (map unFix xs) - return (Just ("["<> (Text.intercalate " " (catMaybes strs)) <> "]")) -toArg _ = return $ Nothing + return (Just ("["<> Text.intercalate " " (catMaybes strs) <> "]")) +toArg _ = return Nothing -- | Print with return line prn :: ReduceUnawareCommand prn args = do strs <- catMaybes <$> mapM toArg args - putStrLn $ (Text.intercalate " " strs) + putStrLn (Text.intercalate " " strs) return Void -- | Print @@ -52,14 +52,14 @@ evalErr errmsg = do -- | Undefine a var undef :: ReduceUnawareCommand -undef ((Atom name):[]) = do +undef [Atom name] = do modify (Map.delete name) return Void undef x = evalErr $ "undef wait an atom got" <> toS (show x) -- | replace à la `sed s/old/new/g text` replace :: ReduceUnawareCommand -replace ((Str old) : (Str new) : (Str text) : []) = +replace [Str old,Str new,Str text] = return $ Str $ Text.replace old new text 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) atom :: ReduceUnawareCommand -atom ((Atom a):[]) = return $ Atom a -atom ((Str s):[]) = return $ Atom s -atom _ = evalErr "atom need an atom or a string" +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) -> 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 ("binary operator needs two numbers. Got: " <> toS (show exprs)) 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" lnot :: ReduceUnawareCommand -lnot ((Bool x):[]) = return ( Bool (not x)) -lnot _ = evalErr "not need a boolean" +lnot [Bool x] = return (Bool (not x)) +lnot _ = evalErr "not need a boolean" toWaitingStream :: ReduceUnawareCommand -toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h)) +toWaitingStream [Stream (Just h) ] = return (WaitingStream (Just h)) toWaitingStream _ = return Void 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)) +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 @@ -124,11 +124,11 @@ fn reducer (p:bodies) = do List args -> do let parameters = map fromAtom args if all isJust parameters - then return (Fn { params = catMaybes parameters - , body = Fix . Lambda . map Fix $ (Atom "do"):bodies - , closure = mempty - , types = ([],LCommand) - }) + then return Fn { params = catMaybes parameters + , body = Fix . Lambda . map Fix $ Atom "do":bodies + , closure = mempty + , types = ([],LCommand) + } else return Void _ -> return Void where fromAtom (Fix (Atom a)) = Just a @@ -162,7 +162,7 @@ strictCommands = [ ("prn", prn) -- | Define a var def :: Command -def _ ((Atom name):v:[]) = do +def _ [Atom name,v] = do modify (Map.insert name v) return v def _ exprs = @@ -173,11 +173,11 @@ doCommand :: Command doCommand reduceLambda (expr:nexpr:exprs) = do _ <- reduceLambda expr doCommand reduceLambda (nexpr:exprs) -doCommand reduceLambda (expr:[]) = reduceLambda expr +doCommand reduceLambda [expr] = reduceLambda expr doCommand _ _ = return Void lishIf :: Command -lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do +lishIf reduceLambda [sexp,sexp1,sexp2] = do reducedSexp <- reduceLambda sexp case reducedSexp of 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" emptyCmd :: Command -emptyCmd _ ((List []):[]) = return (Bool True) -emptyCmd _ ((List _):[]) = return (Bool False) -emptyCmd r (x@(Atom _):[]) = do +emptyCmd _ [List []] = return (Bool True) +emptyCmd _ [List _] = return (Bool False) +emptyCmd r [x@(Atom _)] = do val <- r x - emptyCmd r (val:[]) -emptyCmd r (x@(Lambda _):[]) = do + emptyCmd r [val] +emptyCmd r [x@(Lambda _)] = do val <- r x - emptyCmd r (val:[]) + emptyCmd r [val] emptyCmd _ _ = return Void firstCmd :: Command -firstCmd reducer ((List (x:_)):[]) = reducer (unFix x) -firstCmd _ ((List _):[]) = return Void -firstCmd r (x@(Atom _):[]) = do +firstCmd reducer [List (x:_)] = reducer (unFix x) +firstCmd _ [List _] = return Void +firstCmd r [x@(Atom _)] = do val <- r x - firstCmd r (val:[]) -firstCmd r (x@(Lambda _):[]) = do + firstCmd r [val] +firstCmd r [x@(Lambda _)] = do val <- r x - firstCmd r (val:[]) + firstCmd r [val] firstCmd _ _ = return Void restCmd :: Command -restCmd _ ((List (_:xs)):[]) = return (List xs) -restCmd _ ((List _):[]) = return Void -restCmd r (x@(Atom _):[]) = do +restCmd _ [List (_:xs)] = return (List xs) +restCmd _ [List _] = return Void +restCmd r [x@(Atom _)] = do val <- r x - restCmd r (val:[]) -restCmd r (x@(Lambda _):[]) = do + restCmd r [val] +restCmd r [x@(Lambda _)] = do val <- r x - restCmd r (val:[]) + restCmd r [val] restCmd _ _ = return Void consCmd :: Command -consCmd r (x:(List ls):[]) = do +consCmd r [x,List ls] = do xreduced <- r x return (List (Fix xreduced:ls)) -consCmd r (x:y@(Atom _):[]) = do +consCmd r [x,y@(Atom _)] = do val <- r y - consCmd r (x:val:[]) -consCmd r (x:y@(Lambda _):[]) = do + consCmd r [x,val] +consCmd r [x,y@(Lambda _)] = do val <- r y - consCmd r (x:val:[]) + consCmd r [x,val] consCmd _ _ = return Void equal :: Command -equal r ((List xs):(List ys):[]) = do +equal r [List xs,List ys] = do reducedListX <- traverse r (map unFix xs) reducedListY <- traverse r (map unFix ys) return (Bool (reducedListX == reducedListY)) -equal r (x:y:[]) = do +equal r [x,y] = do reducedX <- r x reducedY <- r y 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 :: Command -export _ ((Atom name):v@(Str s):[]) = do +export _ [Atom name,v@(Str s)] = do liftIO $ setEnv (toS name) (toS s) modify (Map.insert name v) return v -export r (n:value:[]) = do +export r [n,value] = do reducedVal <- r value - export r (n:reducedVal:[]) -export _ _ = evalErr $ "eval need an atom and a string (eval foo \"foo\")" + export r [n,reducedVal] +export _ _ = evalErr "eval need an atom and a string (eval foo \"foo\")" evalStr :: Command -evalStr r ((Str program):[]) = do +evalStr r [Str program] = do let parsed = parseCmd program case parsed of Right expr -> r (unFix expr) _ -> evalErr "evalStr error" -evalStr r (x@(Atom _):[]) = do +evalStr r [x@(Atom _)] = do reduced <- r x - evalStr r (reduced:[]) -evalStr r (x@(Lambda _):[]) = do + evalStr r [reduced] +evalStr r [x@(Lambda _)] = do reduced <- r x - evalStr r (reduced:[]) + evalStr r [reduced] evalStr _ _ = evalErr "evalStr error" -- | retrieve the value of a var getenv :: Command -getenv _ ((Atom varname):[]) = do +getenv _ [Atom varname] = do hm <- get return $ fromMaybe Void (Map.lookup varname hm) -getenv _ ((Str varname):[]) = do +getenv _ [Str varname] = do hm <- get return $ fromMaybe Void (Map.lookup varname hm) getenv r (expr:_) = do @@ -289,11 +289,11 @@ quote :: Command quote _ exprs = return (List (map Fix exprs)) evalList :: Command -evalList r (List exprs:[]) = r (Lambda exprs) -evalList r (x@(Atom _):[]) = do +evalList r [List exprs] = r (Lambda exprs) +evalList r [x@(Atom _)] = do evaluated <- r x evalList r [evaluated] -evalList r (x@(Lambda _):[]) = do +evalList r [x@(Lambda _)] = do evaluated <- r x evalList r [evaluated] evalList _ x = evalErr ("Waiting for a list of exprs got: " <> toS (show x)) diff --git a/src/Lish/Parser.hs b/src/Lish/Parser.hs index 66ef9ff..f76d5a7 100644 --- a/src/Lish/Parser.hs +++ b/src/Lish/Parser.hs @@ -27,7 +27,7 @@ parseNumber = (Fix . Num . fromMaybe 0 . readMaybe) <$> many1 digit parseAtom :: Parser Expr parseAtom = do - frst <- (noneOf " \t()[]\"") + frst <- noneOf " \t()[]\"" rest <- many (noneOf " \t()[]") case frst:rest of "true" -> return . Fix $ Bool True diff --git a/src/Lish/Types.hs b/src/Lish/Types.hs index fb3ed30..f12b329 100644 --- a/src/Lish/Types.hs +++ b/src/Lish/Types.hs @@ -67,11 +67,11 @@ 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 (List sexprs) = "[" <> Text.intercalate " " sexprs <> "]" +repr (Lambda sexprs) = "(" <> Text.intercalate " " sexprs <> ")" repr Void = "ε" -repr (Cmd n args) = "($ " <> n <> (Text.intercalate " " args) <> ")" -repr (Fn p _ _ _) = "(λ" <> (Text.intercalate "." p) <> ". ... )" +repr (Cmd n args) = "($ " <> n <> Text.intercalate " " args <> ")" +repr (Fn p _ _ _) = "(λ" <> Text.intercalate "." p <> ". ... )" repr (Stream _) = "" repr (WaitingStream _) = "" @@ -88,4 +88,4 @@ data InternalCommand = instance Show InternalCommand where show x = toS (_commandName x) instance Eq InternalCommand where - (==) x y = (_commandName x) == (_commandName y) + (==) x y = _commandName x == _commandName y