Use catamorphism

README.md

@@ -1,6 +1,8 @@
 lish
 ==========
 
+[![Build Status](https://travis-ci.org/yogsototh/lish.svg?branch=master)](https://travis-ci.org/yogsototh/lish)
+
 This project is an experimental LISP flavoured Shell
 
 ## Build

lish.cabal

@@ -38,6 +38,7 @@ library
                    , Data.Stack
   build-depends:     base >= 4.8 && < 5
                    , containers
+                   , data-fix
                    , haskeline
                    , parsec >= 3 && < 4
                    , pipes
@@ -66,6 +67,7 @@ test-suite lish-test
                    , tasty-smallcheck >= 0.8
                    , lish
                    , protolude
+                   , data-fix
 
 test-suite lish-doctest
   type:              exitcode-stdio-1.0

src-test/Lish/Test/Parser.hs

@@ -5,11 +5,11 @@ where
 
 import Protolude
 
+import Data.Fix
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.SmallCheck
 
-
 import Lish.Parser
 import Lish.Types
 
@@ -22,13 +22,13 @@ parseTests =
   ]
 
 simpleCommand :: Text -> Assertion
-simpleCommand t = parseCmd t @?= Right (Atom t)
+simpleCommand t = parseCmd t @?= Right (Fix (Atom t))
 
 propAtom :: [Char] -> Bool
 propAtom s = s == "" ||
   fromMaybe '0' (head s) `elem` ("0123456789([])" :: [Char]) ||
   case s of
-  "true" -> parseCmd t == Right (Bool True)
-  "false" -> parseCmd t == Right (Bool False)
-  _ -> parseCmd t == Right (Atom t)
+  "true" -> parseCmd t == Right (Fix (Bool True))
+  "false" -> parseCmd t == Right (Fix (Bool False))
+  _ -> parseCmd t == Right (Fix (Atom t))
   where t = toS s

src/Data/Stack.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Safe              #-}
+
 module Data.Stack
   ( Stack
   , pop
@@ -8,10 +10,10 @@ module Data.Stack
   )
   where
 
-import Protolude
+import           Protolude
 
 -- | Stack data structure
-data Stack a = Stack [a] deriving (Eq,Show)
+data Stack a = Stack ![a] deriving (Eq,Show)
 
 instance Functor Stack where
   fmap f (Stack xs) = Stack (fmap f xs)
@@ -24,33 +26,34 @@ instance Alternative Stack where
   empty = Stack []
   (<|>) (Stack xs) (Stack ys) = Stack (xs <|> ys)
 
--- | push to the stack
+-- | O(1) Push to the stack
 --
--- >>> push empty 0
+-- >>> push 0 empty
 -- Stack [0]
 --
--- >>> push (push empty 0) 1
+-- >>> empty & push 0 & push 1
 -- Stack [1,0]
-push :: Stack a -> a -> Stack a
-push (Stack xs) x = Stack (x:xs)
+push :: a -> Stack a -> Stack a
+push x (Stack xs) = Stack (x:xs)
 
 -- | pop an element from the stack
 --
--- >>> pop (push empty 0)
+-- >>> pop empty
+-- Nothing
+--
+-- >>> pop (push 0 empty)
 -- Just (0,Stack [])
 --
--- >>> pop (push (push empty 0) 1)
+-- >>> pop (empty & push 0 & push 1)
 -- Just (1,Stack [0])
 --
--- >>> pop empty
--- Nothing
 pop :: Stack a -> Maybe (a, Stack a)
 pop (Stack (x:xs)) = Just (x, Stack xs)
-pop _ = Nothing
+pop _              = Nothing
 
 -- | get the element at the top of the stack
 --
--- >>> top (push empty 'c')
+-- >>> top (push 'c' empty)
 -- Just 'c'
 --
 -- >>> top empty
@@ -63,7 +66,7 @@ top stk = fmap fst (pop stk)
 -- >>> size empty
 -- 0
 --
--- >>> size (push (push empty 0) 1)
+-- >>> size (empty & push 0 & push 1)
 -- 2
 size :: Stack a -> Int
 size (Stack l) = length l

src/Lish/Balanced.hs

@@ -17,9 +17,9 @@ import Data.Stack (Stack, pop, push)
 data Balanced = Balanced | Unbalanced Char deriving (Eq, Show)
 
 checkBalanced :: Text -> Stack Char -> Balanced
-checkBalanced (T.uncons -> Just ('(',suf)) stk = checkBalanced suf (push stk '(')
-checkBalanced (T.uncons -> Just ('[',suf)) stk = checkBalanced suf (push stk '[')
-checkBalanced (T.uncons -> Just ('{',suf)) stk = checkBalanced suf (push stk '{')
+checkBalanced (T.uncons -> Just ('(',suf)) stk = checkBalanced suf (push '(' stk)
+checkBalanced (T.uncons -> Just ('[',suf)) stk = checkBalanced suf (push '[' stk)
+checkBalanced (T.uncons -> Just ('{',suf)) stk = checkBalanced suf (push '{' stk)
 
 checkBalanced (T.uncons -> Just (')',suf)) (pop -> Just ('(',stk)) = checkBalanced suf stk
 checkBalanced (T.uncons -> Just (')',_)) _ = Unbalanced ')'

src/Lish/Core.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns      #-}
 -- | Lish core
 module Lish.Core
   (
     runLish
   ) where
 
+import           Data.Fix
 import qualified Data.Map.Strict          as Map
 import           GHC.IO.Handle            (hGetContents)
 import           Pipes
@@ -16,7 +16,7 @@ import           System.Console.Haskeline
 import           System.Environment       (getEnvironment)
 import           Text.Parsec              (ParseError)
 
-import           Lish.Balanced            (checkBalanced, Balanced(..))
+import           Lish.Balanced            (Balanced (..), checkBalanced)
 import           Lish.Eval                (reduceLambda)
 import           Lish.Parser              (parseCmd)
 import           Lish.Types
@@ -59,7 +59,7 @@ mainLoop mc env previousPartialnput = do
       case checkBalanced exprs empty of
         Unbalanced c -> mainLoop (Just c) env exprs
         Balanced -> do
-          newenv <- eval env (parseCmd ("(" <> exprs <> ")"))
+          newenv <- eval env (fmap unFix (parseCmd ("(" <> exprs <> ")")))
           mainLoop Nothing newenv ""
 
     _ -> panic "That should NEVER Happens, please file bug"
@@ -86,7 +86,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 (pprint (Fix x))
 
 -- | Evaluate the parsed expr
 eval :: Env -> Either ParseError SExp -> InputT IO Env

src/Lish/Eval.hs

@@ -9,6 +9,7 @@ module Lish.Eval
   where
 
 import qualified Control.Exception     as Exception
+import           Data.Fix
 import qualified Data.Map.Strict       as Map
 import           Protolude
 import           System.Process        hiding (env)
@@ -23,10 +24,10 @@ infer _ Void = return LVoid
 infer _ (Num _) = return LNum
 infer _ (Bool _) = return LBool
 infer _ (Str _) = return LStr
-infer ctx (List (expr:exprs)) = do
+infer ctx (List ((Fix expr):exprs)) = do
   case infer ctx expr of
     Left terr -> Left terr
-    Right t -> case mapM (\e -> checkType ctx e t) exprs of
+    Right t -> case mapM (\e -> checkType ctx e t) (map unFix exprs) of
       Left terror -> Left terror
       Right _     -> return $ LList t
 infer ctx (Atom a) = case Map.lookup a ctx of
@@ -34,13 +35,13 @@ infer ctx (Atom a) = case Map.lookup a ctx of
   Nothing -> Left . TypeError $ "Undefined atom: " <> toS a
 infer ctx (Fn parameters fnbody _ (ptypes,retType)) = do
   let newCtx = Map.union ctx (Map.fromList (zip parameters ptypes))
-  checkType newCtx fnbody retType
+  checkType newCtx (unFix fnbody) retType
   return $ LFn ptypes retType
-infer ctx (Lambda ((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) exprs
+    inferedTypes <- mapM (infer ctx) (map unFix exprs)
     if inferedTypes /= ptypes
       then Left . TypeError $ "Expected " <> show ptypes
                               <> " bug got " <> show inferedTypes
@@ -60,11 +61,12 @@ checkType ctx expr ty = infer ctx expr >>= \ inferedType ->
 -- its real type should be something isomorphic to
 -- (SExp,Environment) -> IO (SExp, Environment)
 reduceLambda :: SExp -> StateT Env IO SExp
-reduceLambda (Lambda (expr:exprs)) = do
+reduceLambda (Lambda (Fix expr:fexprs)) = do
+  let exprs = map unFix fexprs
   reduced <- reduceLambda expr
   redred <- reduceLambda reduced
   if redred /= reduced
-    then reduceLambda (Lambda (reduced:exprs))
+    then reduceLambda (Lambda . map Fix $ (reduced:exprs))
     else do
       -- DEBUG --env <- get
       -- DEBUG --liftIO $ do
@@ -85,11 +87,11 @@ reduceLambda (Lambda (expr:exprs)) = do
                 Just x  -> return x
                 Nothing -> do
                   reducedArgs <- mapM reduceLambda exprs
-                  executeShell (Lambda ((Atom f):reducedArgs))
+                  executeShell (Lambda . map Fix $ ((Atom f):reducedArgs))
         f@(Fn _ _ _ _) -> applyFn f exprs
         s  -> do
           reducedArgs <- mapM reduceLambda exprs
-          executeShell (Lambda (s:reducedArgs))
+          executeShell (Lambda . map Fix $ (s:reducedArgs))
 reduceLambda (Atom x) = do
   env <- get
   case Map.lookup x env of
@@ -106,7 +108,7 @@ applyFn (Fn par bod clos _) args =
       currentEnv <- get
       -- Run the function in its own closure
       fmap fst $ liftIO $
-        runStateT (reduceLambda bod) (Map.union currentEnv localClosure)
+        runStateT (reduceLambda (unFix bod)) (Map.union currentEnv localClosure)
   where
     bindVars oldenv newvars = Map.union oldenv (Map.fromList newvars)
 applyFn x _ = return x
@@ -138,8 +140,8 @@ shellErr errmsg = do
 -- | Execute a shell command
 executeShell :: SExp -> StateT Env IO SExp
 executeShell (Lambda args) = do
-  res <- (mapM toArg args) >>= return . catMaybes
-  let argsHandle = (filter isJust (map toStdIn args))
+  res <- (mapM toArg (map unFix args)) >>= return . catMaybes
+  let argsHandle = (filter isJust (map toStdIn (map unFix args)))
       stdinhandle = case argsHandle of
                       (Just h:_) -> UseHandle h
                       _          -> Inherit

src/Lish/InternalCommands.hs

@@ -7,6 +7,7 @@ module Lish.InternalCommands
   )
   where
 
+import Data.Fix
 import qualified Data.Map.Strict    as Map
 import qualified Data.Text          as Text
 import           GHC.IO.Handle      (hGetContents)
@@ -132,13 +133,13 @@ fn reducer (p:bodies) = do
       let  parameters = map fromAtom args
       if all isJust parameters
         then return (Fn { params = catMaybes parameters
-                        , body = Lambda $ (Atom "do"):bodies
+                        , body = Fix . Lambda . map Fix $ (Atom "do"):bodies
                         , closure = mempty
                         , types = ([],LCommand)
                         })
         else return Void
     _ -> return Void
-  where fromAtom (Atom a) = Just a
+  where fromAtom (Fix (Atom a)) = Just a
         fromAtom _ = Nothing
 fn _ _ = return Void
 

src/Lish/Parser.hs

@@ -5,44 +5,45 @@ module Lish.Parser
   ( parseCmd )
   where
 
+import           Data.Fix
 import           Protolude        hiding (for, many, optional, try, (<|>))
 import           Text.Parsec
 import           Text.Parsec.Text
 
 import           Lish.Types
 
-parseCmd :: Text -> Either ParseError SExp
+parseCmd :: Text -> Either ParseError Expr
 parseCmd = parse parseExpr "S-Expr"
 
-parseExpr :: Parser SExp
+parseExpr :: Parser Expr
 parseExpr = parseLambda
             <|> parseList
             <|> parseNumber
             <|> parseAtom
             <|> parseString
 
-parseNumber :: Parser SExp
-parseNumber = (Num . fromMaybe 0 . readMaybe) <$> many1 digit
+parseNumber :: Parser Expr
+parseNumber = (Fix . Num . fromMaybe 0 . readMaybe) <$> many1 digit
 
-parseAtom :: Parser SExp
+parseAtom :: Parser Expr
 parseAtom = do
   frst <- (noneOf " \t()[]\"")
   rest <- many (noneOf " \t()[]")
   case frst:rest of
-    "true"  -> return (Bool True)
-    "false" -> return (Bool False)
-    x       -> return (Atom (toS x))
+    "true"  -> return . Fix $ Bool True
+    "false" -> return . Fix $ Bool False
+    x       -> return . Fix $ Atom (toS x)
 
-parseString :: Parser SExp
-parseString = (Str . toS) <$> between (char '"')
-                              (char '"')
-                              (many (noneOf "\""))
+parseString :: Parser Expr
+parseString = (Fix . Str . toS) <$> between (char '"')
+                                            (char '"')
+                                            (many (noneOf "\""))
 
-parseSExps :: Parser [SExp]
-parseSExps = sepEndBy parseExpr spaces
+parseExprs :: Parser [Expr]
+parseExprs = sepEndBy parseExpr spaces
 
-parseLambda :: Parser SExp
-parseLambda = Lambda <$> between (char '(') (char ')') parseSExps
+parseLambda :: Parser Expr
+parseLambda = Fix . Lambda <$> between (char '(') (char ')') parseExprs
 
-parseList :: Parser SExp
-parseList = List <$> between (char '[') (char ']') parseSExps
+parseList :: Parser Expr
+parseList = Fix . List <$> between (char '[') (char ']') parseExprs

src/Lish/Types.hs

@@ -1,10 +1,14 @@
+{-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 -- | Lish types
 module Lish.Types
-  ( SExp(..)
+  ( SExp
+  , Expr
+  , ExprF(..)
   , show
   , repr
+  , pprint
   , Env
   , CmdStream
   , Command
@@ -15,28 +19,32 @@ module Lish.Types
   )
 where
 
-import qualified Data.Map.Strict as Map
+import           Data.Fix
+import           Data.Map.Strict (Map)
 import qualified Data.Text       as Text
 import           GHC.IO.Handle   (Handle)
 import           GHC.Show        (Show (..))
 import           Protolude       hiding (show)
 
-data SExp = Atom Text
-          | Num Integer
-          | Bool Bool
-          | Str Text
-          | List [SExp]
-          | Lambda [SExp]
-          | Void
-          -- only exists during evaluation
-          | Fn { params  :: [Text]
-               , body    :: SExp
-               , closure :: Env
-               , types :: ([LishType],LishType)
-               }
-          | Stream CmdStream
-          | WaitingStream CmdStream
-          deriving (Eq,Show)
+data ExprF a = Atom Text
+             | Num Integer
+             | Bool Bool
+             | Str Text
+             | List [a]
+             | Lambda [a]
+             | Void
+              -- only exists during evaluation
+             | Fn { params  :: [Text]
+                  , body    :: a
+                  , closure :: Env
+                  , types   :: ([LishType],LishType)
+                  }
+             | Stream CmdStream
+             | WaitingStream CmdStream
+             deriving (Eq,Show,Functor)
+
+type Expr = Fix ExprF
+type SExp = ExprF Expr
 
 data LishType = LCommand
               | LNum
@@ -47,21 +55,24 @@ data LishType = LCommand
               | LVoid
               deriving (Eq,Show)
 
-type Context = Map.Map Text LishType
+type Context = Map Text LishType
 
-repr :: SExp -> Text
+repr :: ExprF Text -> Text
 repr (Atom s)          = s
 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 " " (map repr sexprs)) <> "]"
-repr (Lambda sexprs)   = "(" <> (Text.intercalate " " (map repr sexprs)) <> ")"
+repr (List sexprs)     = "[" <> (Text.intercalate " " sexprs) <> "]"
+repr (Lambda sexprs)   = "(" <> (Text.intercalate " " sexprs) <> ")"
 repr Void              = "ε"
 repr (Fn p _ _ _)      = "(λ" <> (Text.intercalate "." p) <> ". ... )"
 repr (Stream _)        = "<stream>"
 repr (WaitingStream _) = "<w-stream>"
 
+pprint :: Expr -> Text
+pprint = cata repr
+
 type CmdStream = Maybe Handle
-type Env = Map.Map Text SExp
+type Env = Map Text SExp
 type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp
 type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand

stack.yaml

@@ -41,6 +41,7 @@ packages:
 # (e.g., acme-missiles-0.3)
 extra-deps:
 - haskeline-0.7.3.1
+- data-fix-0.0.3
 
 # Override default flag values for local packages and extra-deps
 flags: {}