cleaning ns

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

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

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)
+                   ]

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

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 _)        = "<stream>"
+repr (WaitingStream _) = "<w-stream>"
+
+type CmdStream = Maybe Handle
+
+type Command = [SExp] -> IO SExp