minor fixes

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -1,3 +1,7 @@
-/tutorial.md
-/.stack-work/
+.stack-work/
 .lish-history
+.direnv/
+*.tix
+stack.yaml.lock
+dist-newstyle/
+result

Notes.org

@@ -0,0 +1,7 @@
+* Notes
+
+** hlint
+
+#+BEGIN_SRC
+hlint . --report
+#+END_SRC

README.md

@@ -7,19 +7,13 @@ This project is an experimental LISP flavoured Shell
 
 ## Build
 
-Install [`stack`](http://haskellstack.org)
+Install [`nix`](https://nixos.org/nix)
 
 And then
 
 ~~~
 git clone https://github.com/yogsototh/lish.git
 cd lish
-stack setup && stack build
-stack exec -- lish-exe
+nix-shell
+cabal run lish
 ~~~
-
-## To note
-
-This Haskell project use the stack template `tasty-travis`.
-
-Please read file `tutorial.md` for first steps in using the template.

flake.lock

@@ -0,0 +1,42 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1649676176,
+        "narHash": "sha256-OWKJratjt2RW151VUlJPRALb7OU2S5s+f0vLj4o1bHM=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "a4b154ebbdc88c8498a5c7b01589addc9e9cb678",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1652095841,
+        "narHash": "sha256-NYsK0DMjcSyUx1ZYpMMPKx5H1wlDB3M+5Wa6PCWJtOU=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "1f08cf087963aa5537a4a85836bb6343071f68f9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,38 @@
+# SPDX-FileCopyrightText: 2021 Serokell <https://serokell.io/>
+#
+# SPDX-License-Identifier: CC0-1.0
+
+{
+  description = "lish";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+        haskellPackages = pkgs.haskellPackages;
+        jailbreakUnbreak = pkg: pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+        packageName = "lish";
+      in {
+        packages.${packageName} =
+          haskellPackages.callCabal2nix packageName self rec {
+            # Dependency overrides go here
+          };
+
+        defaultPackage = self.packages.${system}.${packageName};
+
+        devShell = pkgs.mkShell {
+          buildInputs = with pkgs; [
+            zlib.dev
+            haskellPackages.haskell-language-server # you must build it with your ghc to work
+            ghcid
+            cabal-install
+          ];
+          inputsFrom = builtins.attrValues self.packages.${system};
+        };
+      });
+}

lish.cabal

@@ -1,6 +1,10 @@
--- This file has been generated from package.yaml by hpack version 0.17.0.
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.7.
 --
 -- see: https://github.com/sol/hpack
+--
+-- hash: 037ccc9ecccf9a8595810c6ffd1691bad8a7a3ececa5f6ef9291eb2605a20e50
 
 name:           lish
 version:        0.1.0.0
@@ -13,8 +17,6 @@ maintainer:     Yann Esposito <yann.esposito@gmail.com>
 license:        PublicDomain
 license-file:   LICENSE
 build-type:     Simple
-cabal-version:  >= 1.10
-
 extra-source-files:
     README.md
     stack.yaml
@@ -28,94 +30,75 @@ library
       src
   ghc-options: -Wall -O2
   build-depends:
-      base >= 4.8 && < 5
+      base
     , containers
     , data-fix
-    , haskeline
-    , parsec >= 3 && < 4
+   , haskeline
+    , parsec
     , pipes
-    , protolude
     , pretty
     , pretty-show
     , process
+    , protolude
     , text
   exposed-modules:
       Data.Stack
-      Lib
       Lish.Balanced
       Lish.Core
       Lish.Eval
       Lish.InternalCommands
       Lish.Parser
       Lish.Types
+  other-modules:
+      Paths_lish
   default-language: Haskell2010
 
 executable lish
   main-is: Main.hs
+  other-modules:
+      Paths_lish
   hs-source-dirs:
       src-exe
   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >= 4.8 && < 5
+      base
     , containers
     , data-fix
     , haskeline
-    , parsec >= 3 && < 4
+    , lish
+    , parsec
     , pipes
-    , protolude
     , pretty
     , pretty-show
     , process
-    , text
-    , lish
-  default-language: Haskell2010
-
-test-suite lish-benchmark
-  type: exitcode-stdio-1.0
-  main-is: Main.hs
-  hs-source-dirs:
-      src-benchmark
-  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      base >= 4.8 && < 5
-    , containers
-    , data-fix
-    , haskeline
-    , parsec >= 3 && < 4
-    , pipes
     , protolude
-    , pretty
-    , pretty-show
-    , process
     , text
-    , lish
-    , base >= 4.8 && < 5
-    , criterion >= 1.1
   default-language: Haskell2010
 
 test-suite lish-doctest
   type: exitcode-stdio-1.0
   main-is: Main.hs
+  other-modules:
+      Paths_lish
   hs-source-dirs:
       src-doctest
   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >= 4.8 && < 5
+      Glob >=0.7
+    , QuickCheck >=2.5
+    , base >=4.8 && <5
     , containers
     , data-fix
+    , doctest >=0.10
     , haskeline
-    , parsec >= 3 && < 4
+    , lish
+    , parsec
     , pipes
-    , protolude
     , pretty
     , pretty-show
     , process
+    , protolude
     , text
-    , lish
-    , base >= 4.8 && < 5
-    , doctest >=0.10
-    , Glob >= 0.7
-    , QuickCheck >= 2.5
   default-language: Haskell2010
 
 test-suite lish-test
@@ -125,24 +108,46 @@ test-suite lish-test
       src-test
   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >= 4.8 && < 5
+      base >=4.8 && <5
     , containers
     , data-fix
     , haskeline
-    , parsec >= 3 && < 4
+    , lish
+    , parsec
     , pipes
-    , protolude
     , pretty
     , pretty-show
     , process
-    , text
-    , lish
-    , base >= 4.8 && < 5
-    , tasty >= 0.11
-    , tasty-hunit >= 0.9
-    , tasty-smallcheck >= 0.8
     , protolude
-    , data-fix
+    , tasty >=0.11
+    , tasty-hunit >=0.9
+    , tasty-smallcheck >=0.8
+    , text
   other-modules:
       Lish.Test.Parser
+      Paths_lish
+  default-language: Haskell2010
+
+benchmark lish-benchmark
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_lish
+  hs-source-dirs:
+      src-benchmark
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.8 && <5
+    , containers
+    , criterion >=1.1
+    , data-fix
+    , haskeline
+    , lish
+    , parsec
+    , pipes
+    , pretty
+    , pretty-show
+    , process
+    , protolude
+    , text
   default-language: Haskell2010

lish/core.lsh

@@ -1,11 +1,14 @@
-;; This is lish core
+(comment This is lish core)
 
 (def require (fn [x] (eval (str "(do " (cat x) ")"))))
 
-;; increment
 (def inc (fn [x] (+ x 1)))
 
-;; map
+(def range (fn [from to]
+     (if (< from to)
+         (cons from (range (inc from) to))
+         [])))
+
 (def map (fn [f lst]
           (if (empty? lst)
             []

package.yaml

@@ -13,11 +13,11 @@ extra-source-files:
 ghc-options: -Wall -O2
 
 dependencies:
-  - base >= 4.8 && < 5
+  - base
   - containers
   - data-fix
   - haskeline
-  - parsec >= 3 && < 4
+  - parsec
   - pipes
   - protolude
   - pretty
@@ -59,6 +59,8 @@ tests:
       - doctest >=0.10
       - Glob >= 0.7
       - QuickCheck >= 2.5
+      - protolude
+benchmarks:
   lish-benchmark:
     source-dirs: src-benchmark
     main: Main.hs

src-benchmark/Main.hs

@@ -1,7 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+import Protolude
+
 import Criterion
 import Criterion.Main
 
-import Lib (inc)
+import Lish.Parser (parseCmd)
 
 main :: IO ()
-main = defaultMain [bench "inc 41" (whnf inc (41 :: Int))]
+main = defaultMain
+  [bench "parseCmd (foo \"bar\")"
+    (whnf parseCmd "(foo \"bar\")")
+  , bench "parseCmd (f (f ..28x...))"
+    (whnf parseCmd "(f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f ))))))))))))))))))))))))")
+  ]

src-test/Lish/Test/Parser.hs

@@ -14,13 +14,19 @@ import Test.Tasty.SmallCheck
 import Lish.Parser
 import Lish.Types
 
-parseTests :: [TestTree]
+parseTests :: TestTree
 parseTests =
-  [ testCase "simple commands" (simpleCommand "ls")
-  , testCase "simple commands" (simpleCommand "atom")
-  , testCase "simple commands" (simpleCommand "_foo")
-  , testCase "multiline command"
-             (parseCmd "(fn [x] ; comment \n   (+ x 1))" @?= Right incExpr)
+  testGroup "simple commands"
+  [ testCase "ls" (simpleCommand "ls")
+  , testCase "atom" (simpleCommand "atom")
+  , testCase "_foo" (simpleCommand "_foo")
+  , testCase "multiline"
+             (parseCmd "(fn [x]\n  (+ x 1))" @?= Right incExpr)
+  , testCase "multiline 2"
+             (parseCmd "(fn\n [x]\n  (+ x 1))" @?= Right incExpr)
+  -- TODO: or not? support line comment
+  -- , testCase "multiline command with comment"
+  --            (parseCmd "(fn [x] ; comment \n   (+ x 1))" @?= Right incExpr)
   , testProperty "simple" propAtom
   ]
 

src-test/Main.hs

@@ -2,17 +2,18 @@ import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.SmallCheck
 
-import Lib (inc)
 import Lish.Test.Parser
 
 main :: IO ()
 main = defaultMain $ testGroup "all-tests" tests
 
+inc = (+1)
+
 tests :: [TestTree]
 tests =
   [ testGroup "SmallCheck" scTests
   , testGroup "Unit tests" huTests
-  , testGroup "Lish.Parser" parseTests
+  , parseTests
   ]
 
 scTests :: [TestTree]

src/Data/Stack.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE Safe              #-}
+{-# LANGUAGE Strict #-}
 
 module Data.Stack
   ( Stack

src/Lib.hs

@@ -1,24 +0,0 @@
--- | Example of a library file. It is also used for testing the test suites.
-module Lib
-  (
-    -- * Exported functions
-    inc
-  ) where
-
--- | Increment one 'Num' value.
---
---  >>> let answer = 42 :: Int
---  >>> let prev = answer - 1
---  >>> inc prev
---  42
---  >>> succ . Prelude.last . Prelude.take prev . iterate inc $ 1
---  42
---
---  Properties:
---
---  prop> succ x == inc x
---  prop> inc (negate x) == negate (pred x)
---
-inc :: Num a => a -- ^ value to increment
-             -> a -- ^ result
-inc x = x + 1

src/Lish/Core.hs

@@ -8,10 +8,11 @@ module Lish.Core
 
 import           Data.Fix
 import qualified Data.Map.Strict          as Map
-import           GHC.IO.Handle            (hGetContents)
+import           GHC.IO.Handle            (hGetContents,BufferMode(..),hSetBuffering)
 import           Pipes
+import qualified Pipes.Prelude as P
 import           Prelude                  (String, lines)
-import           Protolude                hiding (for, many, show, (<|>))
+import           Protolude                hiding (for, many, show, (<|>), lines, yield)
 import           System.Console.Haskeline
 import           System.Environment       (getEnvironment)
 import           Text.Parsec              (ParseError)
@@ -46,7 +47,7 @@ toEnv env =
 -- So if the first argument is not Nothing, it means we are in the middle
 -- of a multiline expression.
 mainLoop :: Maybe Char -- ^ Check to know if we are in the middle of the writting of a multiline expression
-         -> Env -- ^ The Lish environement
+         -> Env -- ^ The Lish environment
          -> Text -- ^ The previous partial input (if in the middle of a multiline expression)
          -> InputT IO ()
 mainLoop mc env previousPartialnput = do
@@ -81,16 +82,12 @@ evalReduced :: SExp -> IO ()
 evalReduced Void = return ()
 evalReduced (Stream Nothing) = return ()
 evalReduced (Stream (Just h)) = do
-  cmdoutput <- hGetContents h
-  let splittedLines = lines cmdoutput
-      producer = mapM_ yield splittedLines
-  runEffect (for producer (lift . putStrLn))
+  hSetBuffering h NoBuffering
+  runEffect $ for (P.fromHandle h) $ \str -> lift (putStrLn str)
 evalReduced (WaitingStream Nothing) = return ()
 evalReduced (WaitingStream (Just h)) = do
-  cmdoutput <- hGetContents h
-  let splittedLines = lines cmdoutput
-      producer = mapM_ yield splittedLines
-  runEffect (for producer (lift . putStrLn))
+  hSetBuffering h NoBuffering
+  runEffect $ for (P.fromHandle h) $ \str -> lift (putStrLn str)
 evalReduced x = putStrLn (pprint (Fix x))
 
 -- | Evaluate the parsed expr

src/Lish/Eval.hs

@@ -8,11 +8,13 @@ module Lish.Eval
   )
   where
 
+import           GHC.IO.Handle            (hGetContents,BufferMode(..),hSetBuffering)
 import qualified Control.Exception     as Exception
 import           Data.Fix
 import qualified Data.Map.Strict       as Map
 import           Protolude
-import           System.Process        hiding (env)
+import           System.Process        (createProcess,CreateProcess(..),StdStream(..),proc)
+-- import           System.Process.Streaming
 import qualified Text.Show.Pretty as Pr
 
 import           Lish.InternalCommands (toArg)
@@ -25,10 +27,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 +40,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 +55,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 +72,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))
@@ -86,17 +87,17 @@ _reduceLambda (Atom x) = do
     Just s -> return s
     _      -> case InternalCommands.lookup x of
       Just cmd -> return (Internal cmd)
-      _         -> return (Str x)
-_reduceLambda x          = return x
+      _        -> return (Str x)
+_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)
-      putStrLn $ Pr.ppShow env
+      -- putStr ("Env: " :: Text)
+      -- putStrLn $ Pr.ppShow env
       putStr ("Arg: " :: Text)
       putStrLn $ pprint (Fix x)
     _ -> return ()
@@ -131,14 +132,16 @@ 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)))
-      stdinhandle = case argsHandle of
-                      (Just h:_) -> UseHandle h
-                      _          -> Inherit
-  case (map toS res) of
+  res <- fmap catMaybes (traverse (toArg . unFix) args)
+  let argsHandle = filter isJust (map (toStdIn . unFix) args)
+  stdinhandle <- case argsHandle of
+                      (Just h:_) -> do
+                          lift $ hSetBuffering h NoBuffering
+                          return $ UseHandle h
+                      _          -> return Inherit
+  case map toS res of
     sargs -> do
-      result <- lift . trySh $
+      result <- lift . trySh $ do
         createProcess (proc (toS cmdName) sargs)
                       { std_in = stdinhandle
                       , std_out = CreatePipe }

src/Lish/InternalCommands.hs

@@ -11,7 +11,7 @@ import           Data.Fix
 import qualified Data.Map.Strict    as Map
 import qualified Data.Text          as Text
 import           GHC.IO.Handle      (hGetContents)
-import           Protolude          hiding (show)
+import           Protolude          hiding (show,replace)
 import           System.Environment (setEnv)
 
 import           Lish.Parser        (parseCmd)
@@ -27,15 +27,15 @@ toArg (Str s)           = return $ Just $ toS s
 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
+  strs <- traverse (toArg . unFix) xs
+  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,50 +52,48 @@ 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"
 
 -- | create a string and concat multiple elements
 str :: ReduceUnawareCommand
-str exprs = do
-  args <- catMaybes <$> mapM toArg exprs
-  return $ Str $ Text.concat args
+str exprs = Str . Text.concat . catMaybes <$> mapM toArg exprs
 
 -- | 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 _                     = return Void
+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 +122,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
@@ -138,7 +136,7 @@ fn _ _ = return Void
 strictCommands :: [(Text,ReduceUnawareCommand)]
 strictCommands = [ ("prn", prn)
                  , ("pr", pr)
-                 , (">", toWaitingStream)
+                 , ("<-", toWaitingStream)
                  , ("replace", replace)
                  , ("undef",undef)
                  , ("str",str)
@@ -162,7 +160,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 +171,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,94 +184,90 @@ 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
-  reducedListX <- traverse r (map unFix xs)
-  reducedListY <- traverse r (map unFix ys)
+equal r [List xs,List ys] = do
+  reducedListX <- traverse (r . unFix) xs
+  reducedListY <- traverse (r . 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
-  hm <- get
-  return $ fromMaybe Void (Map.lookup varname hm)
-getenv _ ((Str varname):[]) = do
-  hm <- get
-  return $ fromMaybe Void (Map.lookup varname hm)
+getenv _ [Atom varname] = fromMaybe Void . Map.lookup varname <$> get
+getenv _ [Str varname] = fromMaybe Void . Map.lookup varname <$> get
 getenv r (expr:_) = do
   reduced <- r expr
   hm <- get
@@ -282,6 +276,22 @@ getenv r (expr:_) = do
     _ -> evalErr "getenv need on atom or a string as argument"
 getenv _ _ = evalErr "getenv need on atom or a string as argument"
 
+comment :: Command
+comment _ _ = return Void
+
+quote :: Command
+quote _ exprs = return (List (map Fix exprs))
+
+evalList :: Command
+evalList r [List exprs] = r (Lambda exprs)
+evalList r [x@(Atom _)] = do
+  evaluated <- r x
+  evalList r [evaluated]
+evalList r [x@(Lambda _)] = do
+  evaluated <- r x
+  evalList r [evaluated]
+evalList _ x = evalErr ("Waiting for a list of exprs got: " <> toS (show x))
+
 unstrictCommands :: [(Text,InternalCommand)]
 unstrictCommands = [ ("if", InternalCommand "if" lishIf)
                    , ("def", InternalCommand "def" def)
@@ -289,9 +299,12 @@ unstrictCommands = [ ("if", InternalCommand "if" lishIf)
                    , ("do", InternalCommand "do" doCommand)
                    , ("=", InternalCommand "=" equal)
                    , ("export", InternalCommand "export" export)
-                   , ("eval", InternalCommand "eval" evalStr)
+                   , ("quote", InternalCommand "quote" quote)
+                   , ("eval-str", InternalCommand "eval-str" evalStr)
+                   , ("eval", InternalCommand "eval" evalList)
                    , ("getenv", InternalCommand "getenv" getenv)
                    , ("$", InternalCommand "$" getenv)
+                   , ("comment", InternalCommand "comment" comment)
                    -- list ops
                    , ("empty?",InternalCommand "empty?" emptyCmd)
                    , ("first",InternalCommand "first" firstCmd)

src/Lish/Parser.hs

@@ -6,7 +6,6 @@ module Lish.Parser
   where
 
 import           Data.Fix
-import qualified Data.Text        as Text
 import           Protolude        hiding (for, many, optional, try, (<|>))
 import           Text.Parsec
 import           Text.Parsec.Text
@@ -14,14 +13,7 @@ import           Text.Parsec.Text
 import           Lish.Types
 
 parseCmd :: Text -> Either ParseError Expr
-parseCmd = parse parseExpr "S-Expr" . Text.strip . eatComment
-
-eatComment :: Text -> Text
-eatComment t =
-  t
-  & Text.lines
-  & map (Text.takeWhile (/= ';'))
-  & Text.intercalate "\n"
+parseCmd = parse parseExpr "S-Expr"
 
 parseExpr :: Parser Expr
 parseExpr = parseLambda
@@ -31,21 +23,19 @@ parseExpr = parseLambda
             <|> parseString
 
 parseNumber :: Parser Expr
-parseNumber = (Fix . Num . fromMaybe 0 . readMaybe) <$> many1 digit
+parseNumber = Fix . Num . fromMaybe 0 . readMaybe <$> many1 digit
 
 parseAtom :: Parser Expr
 parseAtom = do
-  frst <- (noneOf " \t()[]\"")
-  rest <- many (noneOf " \t()[]")
+  frst <- noneOf " \t\n()[]{}\""
+  rest <- many (noneOf " \t\n()[]{}")
   case frst:rest of
     "true"  -> return . Fix $ Bool True
     "false" -> return . Fix $ Bool False
     x       -> return . Fix $ Atom (toS x)
 
 parseString :: Parser Expr
-parseString = (Fix . Str . toS) <$> between (char '"')
-                                            (char '"')
-                                            (many (noneOf "\""))
+parseString = Fix . Str . toS <$> between (char '"') (char '"') (many (noneOf "\""))
 
 parseExprs :: Parser [Expr]
 parseExprs = sepEndBy parseExpr spaces

src/Lish/Types.hs

@@ -1,91 +1,149 @@
-{-# LANGUAGE DeriveFunctor     #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
 -- | Lish types
 module Lish.Types
-  ( SExp
-  , Expr
-  , ExprF(..)
-  , show
-  , repr
-  , pprint
-  , Env
-  , CmdStream
-  , Command
-  , InternalCommand (..)
-  , ReduceUnawareCommand
-  -- types
-  , LishType(..)
-  , Context
+  ( SExp,
+    Expr,
+    ExprF (..),
+    show,
+    repr,
+    pprint,
+    Env,
+    CmdStream,
+    Command,
+    InternalCommand (..),
+    ReduceUnawareCommand,
+    -- types
+    LishType (..),
+    Context,
   )
 where
 
-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)
+import Protolude hiding (show,repr)
+
+import Data.Fix (foldFix, Fix)
+import Data.Functor.Classes (Eq1(..), eq1, Show1(..), showsPrec1, showsUnaryWith, showsBinaryWith)
+import qualified Data.Text as Text
+import GHC.Show (Show (..), showString)
+
+-- | Type representing an expression
+data ExprF a
+  = -- | an atom is just a variable name
+    Atom Text
+  | -- | a number
+    Num Integer
+  | -- | a boolean
+    Bool Bool
+  | -- | a string
+    Str Text
+  | -- | a list
+    List [a]
+  | -- | a function (lambda expression)
+    Lambda [a]
+  | -- | an empty value
+    -- only exists during evaluation
+    Void
+  | Internal InternalCommand
+  | Fn
+      { params :: [Text],
+        body :: a,
+        closure :: Env,
+        types :: ([LishType], LishType)
+      }
+  | Cmd
+      { _cmdName :: a,
+        _cmdArgs :: [a]
+      }
+  | Stream CmdStream
+  | WaitingStream CmdStream
+  deriving (Functor)
+
+instance Eq1 ExprF where
+  liftEq eq (Atom x) (Atom y) = x == y
+  liftEq eq (Num x) (Num y) = x == y
+  liftEq eq (Bool x) (Bool y) = x == y
+  liftEq eq (Str x) (Str y) = x == y
+  liftEq eq (List x) (List y) = all identity (zipWith eq x y)
+  liftEq eq (Lambda x) (Lambda y) = all identity (zipWith eq x y)
+  liftEq _ Void Void = True
+  liftEq eq (Internal x) (Internal y) = x == y
+  liftEq eq (Cmd x1 x2) (Cmd y1 y2) = eq x1 y1 && all identity (zipWith eq x2 y2)
+  liftEq eq (Stream x) (Stream y) = x == y
+  liftEq eq (WaitingStream x) (WaitingStream y) = x == y
+  liftEq _ _ _ = False
+
+instance (Eq a) => Eq (ExprF a) where
+  (==) = eq1
+
+instance Show1 ExprF where
+  liftShowsPrec sp sl d (Atom x) = showString (toS x)
+  liftShowsPrec sp sl d (Num x)  = showString (show x)
+  liftShowsPrec sp sl d (Bool x) = showString (show x)
+  liftShowsPrec sp sl d (Str x)  = showString (show x)
+  liftShowsPrec sp sl d (List x)          = showString "List" -- showsUnaryWith sp "List " d x
+  liftShowsPrec sp sl d (Lambda x)        = showString "Lambda" -- showsUnaryWith sp "Lambda " d x
+  liftShowsPrec sp sl d Void              = showString "Void"
+  liftShowsPrec sp sl d (Internal x)      = showString (show x)
+  liftShowsPrec sp sl d (Cmd x1 x2)       = showsUnaryWith sp "Cmd " d x1 -- todo show x2
+  liftShowsPrec sp sl d (Stream x)        = showString "Stream "
+  liftShowsPrec sp sl d (WaitingStream x) = showString "WaitingStream "
+
+instance (Show a) => Show (ExprF a) where
+  showsPrec = showsPrec1
 
-data ExprF a = Atom Text
-             | Num Integer
-             | Bool Bool
-             | Str Text
-             | List [a]
-             | Lambda [a]
-             | Void
-              -- only exists during evaluation
-             | Internal InternalCommand
-             | Fn { params  :: [Text]
-                  , body    :: a
-                  , closure :: Env
-                  , types   :: ([LishType],LishType)
-                  }
-             | Cmd { _cmdName :: a
-                   , _cmdArgs :: [a]}
-             | Stream CmdStream
-             | WaitingStream CmdStream
-             deriving (Eq, Show, Functor)
 
 type Expr = Fix ExprF
+
 type SExp = ExprF Expr
 
-data LishType = LCommand
-              | LNum
-              | LBool
-              | LStr
-              | LList LishType
-              | LFn [LishType] LishType
-              | LVoid
-              deriving (Eq,Show)
+data LishType
+  = LCommand
+  | LNum
+  | LBool
+  | LStr
+  | LList LishType
+  | LFn [LishType] LishType
+  | LVoid
+  deriving (Eq, Show)
 
 type Context = Map Text LishType
 
 repr :: ExprF Text -> Text
-repr (Atom s)          = s
-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 Void              = "ε"
-repr (Cmd n args)  = "($ " <> n <> (Text.intercalate " " args) <> ")"
-repr (Fn p _ _ _)      = "(λ" <> (Text.intercalate "." p) <> ". ... )"
-repr (Stream _)        = "<stream>"
+repr (Atom s) = s
+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 Void = "ε"
+repr (Cmd n args) = "($ " <> n <> Text.intercalate " " args <> ")"
+repr (Fn p _ _ _) = "(λ" <> Text.intercalate "." p <> ". ... )"
+repr (Stream _) = "<stream>"
 repr (WaitingStream _) = "<w-stream>"
 
 pprint :: Expr -> Text
-pprint = cata repr
+pprint = foldFix repr
 
 type CmdStream = Maybe Handle
+
 type Env = Map Text SExp
+
 type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp
+
 type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand
-data InternalCommand =
-  InternalCommand { _commandName :: Text
-                  , _commandFn :: Command }
+
+data InternalCommand = InternalCommand
+  { _commandName :: Text,
+    _commandFn :: Command
+  }
+
 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

stack.yaml

@@ -1,21 +1,7 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
+# This file was automatically generated by 'stack init' # # Some commonly used options have been documented as comments in this file. # For advanced use and comprehensive documentation of the format, please see: # http://docs.haskellstack.org/en/stable/yaml_configuration/ # Resolver to choose a 'specific' stackage snapshot or a compiler version. # A snapshot resolver dictates the compiler version and the set of packages # to be used for project dependencies. For example: # # resolver: lts-3.5 # resolver: nightly-2015-09-21 # resolver: ghc-7.10.2 # resolver: ghcjs-0.1.0_ghc-7.10.2 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-8.0
+resolver: lts-14.3
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -39,9 +25,7 @@ packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps:
-- haskeline-0.7.3.1
-- data-fix-0.0.3
+extra-deps: []
 
 # Override default flag values for local packages and extra-deps
 flags: {}

tutorial.md

@@ -0,0 +1,98 @@
+
+Thanks for using the stack template `tasty-travis`! This file is here to guide
+you through customizing the template files.
+
+This template allows you to start a simple Haskell project, either to create a
+library or an application. It offers you the choice to customize the source
+directory while providing hints on the proposed hierarchy that the author uses
+(inspired by other Haskell projects).
+
+In the following sections, I will explain how to use the template.
+
+1. Initial configurations
+=========================
+
+Before you get started, there are a few things that this template couldn't
+provide for you. You should:
+
+* Add a synopsis to `lish.cabal`. It should be a short, one sentence
+  explanation of your project.
+
+* Edit the description field in `lish.cabal` if you don't like having
+  the description in the `README.md` file.
+
+* In `lish.cabal`, the category of the project has been set as 'Test'.
+  You might wish to change it to a more descriptive value. A list of
+  categories that you can use for the project is available on Hackage at
+  <http://hackage.haskell.org/packages>. Alternatively, you might prefer using
+  a name from the shorter list at
+  <https://byorgey.wordpress.com/2010/04/15/cabal-init/>.
+
+* If you haven't provided the `author-email`, `author-name`, and
+  `github-username` to the `config.yaml` global file, you will have to search
+  for "TODO" markup and complete this information in `lish.cabal` and/or
+  in `LICENSE`.
+
+2. Creating the git repository
+==============================
+
+If this project is a subdirectory of a larger project with an existing version
+control or you want to use another version control system or another setup,
+then you can ignore this section.
+
+From the root directory of the project (the directory of this file) you will
+need to run the following three commands:
+
+    git init
+    git add .
+    git commit -m "Initial commit"
+
+Now you can create a repository on GitHub to publish the code.
+
+Note that this file is excluded from the repository by being included in the
+`.gitignore` file. If you want this file to be tracked, you can remove the
+line `/tutorial.md` from that file.
+
+3. Testing the initial code
+===========================
+
+These are the stack commands you will likely use the most:
+
+``` sh
+# Build the project.