diff --git a/lish.cabal b/lish.cabal index 860707b..2280983 100644 --- a/lish.cabal +++ b/lish.cabal @@ -30,6 +30,9 @@ library hs-source-dirs: src exposed-modules: Lib , Lish.Core + , Lish.InternalCommands + , Lish.Parser + , Lish.Types build-depends: base >= 4.8 && < 5 , haskeline , parsec >= 3 && < 4 diff --git a/src/Lish/Core.hs b/src/Lish/Core.hs index 45e7799..c84a914 100644 --- a/src/Lish/Core.hs +++ b/src/Lish/Core.hs @@ -7,18 +7,18 @@ module Lish.Core ) where import qualified Control.Exception as Exception -import Data.Char (isSpace) -import Data.List (intercalate) import Data.Maybe (catMaybes, isJust) -import qualified Data.Text as Text import GHC.IO.Handle (Handle, hGetContents) -import GHC.Show (Show (..)) import Pipes import Prelude (String, lines, lookup) import Protolude hiding (for, many, show, (<|>)) import System.Console.Haskeline import System.Process -import Text.Parsec +import Text.Parsec (ParseError) + +import Lish.InternalCommands +import Lish.Parser +import Lish.Types -- | Start an interactive lish shell runLish :: IO () @@ -36,109 +36,6 @@ mainLoop = do eval (parseCmd ("(" <> line <> ")")) mainLoop -data SExp = Lambda [SExp] - | Void - | Atom Text - | Str Text - | List [SExp] - -- Temporal values only present during reduction/evaluation - | Stream CmdStream - | WaitingStream CmdStream - -instance Show SExp where - show = repr - --- | a Command is a function that takes arguments --- and then returns an output that will be a list of lines --- type CmdStream = Producer String IO () -type CmdStream = Maybe Handle - --- | = PARSE - -parseCmd :: String -> Either ParseError SExp -parseCmd = parse parseExpr "S-Expr" - -parseExpr :: Parsec String () SExp -parseExpr = parseLambda - <|> parseList - <|> parseAtom - <|> parseString - -parseAtom :: Parsec String () SExp -parseAtom = Atom <$> do frst <- (noneOf " \t()[]\"") - rest <- many (noneOf " \t()[]") - return $ toS (frst:rest) - -parseString :: Parsec String () SExp -parseString = (Str . toS) <$> between (char '"') - (char '"') - (many (noneOf "\"")) - -parseSExps :: Parsec String () [SExp] -parseSExps = sepEndBy parseExpr spaces - -parseLambda :: Parsec String () SExp -parseLambda = Lambda <$> between (char '(') (char ')') parseSExps - -parseList :: Parsec String () SExp -parseList = List <$> between (char '[') (char ']') parseSExps - - - --- | --- = EVAL - --- | --- == INTERNAL COMMANDS - -prn :: Command -prn strs = do - args <- fmap catMaybes (mapM toArg strs) - putStrLn (intercalate " " args) - return Void - -pr :: Command -pr strs = do - args <- fmap catMaybes (mapM toArg strs) - putStr (intercalate " " args) - return Void - -evalErr :: Text -> IO SExp -evalErr errmsg = do - putText $ "EvalError: " <> errmsg - return Void - -replace :: Command -replace ((Str old):(Str new):(Str str):[]) = - return $ Str $ Text.replace old new str -replace _ = evalErr "replace should take 3 String arguments" - -toWaitingStream :: Command -toWaitingStream (Stream (Just h):[]) = return (WaitingStream (Just h)) -toWaitingStream _ = return Void - -type Command = [SExp] -> IO SExp - -internalCommands :: [(Text,Command)] -internalCommands = [ ("prn", prn) - , ("pr", pr) - , (">", toWaitingStream) - , ("replace", replace) - ] --- --- internalFunction :: String -> Maybe Command --- internalFunction cmdname = lookup cmdname internalCommands - -trim :: String -> String -trim = f . f - where f = reverse . dropWhile isSpace - -toArg :: SExp -> IO (Maybe String) -toArg (Atom x) = return $ Just $ toS x -toArg (Str s) = return $ Just $ toS s -toArg (Stream (Just h)) = fmap (Just . trim) (hGetContents h) -toArg _ = return $ Nothing - toStdIn :: SExp -> Maybe Handle toStdIn (WaitingStream h) = h toStdIn _ = Nothing @@ -155,13 +52,13 @@ executeShell (Lambda args) = do stdinhandle = case argsHandle of (Just h:_) -> UseHandle h _ -> Inherit - case res of + case (map toS res) of (cmd:sargs) -> do result <- trySh $ createProcess (proc cmd sargs) { std_in = stdinhandle , std_out = CreatePipe } case result of Right (_, mb_hout, _, _) -> return $ Stream mb_hout - Left ex -> shellErr ("[shell 1/2] " <> repr (Lambda args) <> "\n[shell 2/2] " <> show ex) + Left ex -> shellErr ("[shell 1/2] " <> (show (Lambda args)) <> "\n[shell 2/2] " <> show ex) _ -> shellErr "empty lambda!" where trySh :: IO a -> IO (Either IOException a) @@ -174,13 +71,6 @@ eval parsed = case parsed of Right sexp -> liftIO (reduceLambda sexp >>= evalReduced) Left err -> outputStrLn (show err) -repr :: SExp -> String -repr (Atom s) = toS s -repr (Str s) = "\"" <> toS s <> "\"" -repr (Lambda sexprs) = "(λ." <> (intercalate " " (map repr sexprs)) <> ")" -repr (List sexprs) = "[" <> (intercalate " " (map repr sexprs)) <> "]" -repr _ = "" - evalReduced :: SExp -> IO () evalReduced Void = return () evalReduced (Stream Nothing) = return () @@ -195,7 +85,7 @@ evalReduced (WaitingStream (Just h)) = do let splittedLines = lines cmdoutput producer = mapM_ yield splittedLines runEffect (for producer (lift . putStrLn)) -evalReduced x = putStrLn (repr x) +evalReduced x = putStrLn (show x) reduceLambda :: SExp -> IO SExp reduceLambda (Lambda exprs) = do diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs new file mode 100644 index 0000000..f9d08e1 --- /dev/null +++ b/src/Lish/InternalCommands.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Lish internal commands +module Lish.InternalCommands + ( internalCommands + , toArg + ) + where + +import GHC.IO.Handle (hGetContents) +import qualified Data.Text as Text +import Lish.Types +import Protolude + +toArg :: SExp -> IO (Maybe Text) +toArg (Atom x) = return $ Just $ toS x +toArg (Str s) = return $ Just $ toS s +toArg (Stream (Just h)) = fmap (Just . Text.strip .toS) (hGetContents h) +toArg _ = return $ Nothing + +prn :: Command +prn args = do + strs <- catMaybes <$> (mapM toArg args) + putText (Text.intercalate " " strs) + return Void + +pr :: Command +pr args = do + strs <- catMaybes <$> (mapM toArg args) + putText (Text.intercalate " " strs) + return Void + +evalErr :: Text -> IO SExp +evalErr errmsg = do + putText $ "EvalError: " <> errmsg + return Void + +replace :: Command +replace ((Str old):(Str new):(Str str):[]) = + return . Str $ Text.replace old new str +replace _ = evalErr "replace should take 3 String arguments" + +toWaitingStream :: Command +toWaitingStream ((Stream (Just h)):[]) = return (WaitingStream (Just h)) +toWaitingStream _ = return Void + +internalCommands :: [(Text,Command)] +internalCommands = [ ("prn", prn) + , ("pr", pr) + , (">", toWaitingStream) + , ("replace", replace) + ] diff --git a/src/Lish/Parser.hs b/src/Lish/Parser.hs new file mode 100644 index 0000000..5c72e8b --- /dev/null +++ b/src/Lish/Parser.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Lish parser +module Lish.Parser + (parseCmd) + where + +import Prelude (String) +import Protolude hiding (for, many, (<|>)) +import Text.Parsec + +import Lish.Types + +parseCmd :: String -> Either ParseError SExp +parseCmd = parse parseExpr "S-Expr" + +parseExpr :: Parsec String () SExp +parseExpr = parseLambda + <|> parseList + <|> parseAtom + <|> parseString + +parseAtom :: Parsec String () SExp +parseAtom = Atom <$> do frst <- (noneOf " \t()[]\"") + rest <- many (noneOf " \t()[]") + return $ toS (frst:rest) + +parseString :: Parsec String () SExp +parseString = (Str . toS) <$> between (char '"') + (char '"') + (many (noneOf "\"")) + +parseSExps :: Parsec String () [SExp] +parseSExps = sepEndBy parseExpr spaces + +parseLambda :: Parsec String () SExp +parseLambda = Lambda <$> between (char '(') (char ')') parseSExps + +parseList :: Parsec String () SExp +parseList = List <$> between (char '[') (char ']') parseSExps diff --git a/src/Lish/Types.hs b/src/Lish/Types.hs new file mode 100644 index 0000000..bca7067 --- /dev/null +++ b/src/Lish/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Lish types +module Lish.Types + ( SExp(..) + , show + , CmdStream + , Command + ) +where + +import qualified Data.Text as Text +import GHC.IO.Handle (Handle) +import GHC.Show (Show (..)) +import Protolude hiding (show) + +data SExp = Lambda [SExp] + | Atom Text + | List [SExp] + | Str Text + | Void + -- only exists during evaluation + | Stream CmdStream + | WaitingStream CmdStream + +instance Show SExp where + show = toS . repr + +repr :: SExp -> Text +repr (Atom s) = s +repr (Str s) = "\"" <> toS s <> "\"" +repr (Lambda sexprs) = "(λ." <> (Text.intercalate " " (map repr sexprs)) <> ")" +repr (List sexprs) = "[" <> (Text.intercalate " " (map repr sexprs)) <> "]" +repr Void = "ε" +repr (Stream _) = "" +repr (WaitingStream _) = "" + +type CmdStream = Maybe Handle + +type Command = [SExp] -> IO SExp