Compare commits

...

8 Commits

@ -0,0 +1 @@
eval "$(lorri direnv)"

7
.gitignore vendored

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

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

@ -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.

@ -0,0 +1,35 @@
{ nixpkgs ? import ./nixpkgs.nix
, compiler ? "default"
, doBenchmark ? false }:
let
inherit (nixpkgs) pkgs;
name = "lish";
haskellPackages = pkgs.haskellPackages;
variant = if doBenchmark
then pkgs.haskell.lib.doBenchmark
else pkgs.lib.id;
drv = haskellPackages.callCabal2nix name ./. {};
in
{
lish = drv;
shell = haskellPackages.shellFor {
# generate hoogle doc
withHoogle = true;
packages = p: [drv];
# packages dependencies (by default haskellPackages)
buildInputs = with haskellPackages;
[ hlint
ghcid
cabal-install
cabal2nix
hindent
# # if you want to add some system lib like ncurses
# # you could by writing it like:
# pkgs.ncurses
];
# nice prompt for the nix-shell
shellHook = ''
export PS1="\n\[[${name}:\033[1;32m\]\W\[\033[0m\]]> "
'';
};
}

File diff suppressed because one or more lines are too long

@ -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.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: b92e83b0e38dda1f7f335624325151ef2a4f95fbe2676a6e77d7bbea14b7e930
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,121 +30,124 @@ library
src
ghc-options: -Wall -O2
build-depends:
base >= 4.8 && < 5
base >=4.8 && <5
, containers
, data-fix
, haskeline
, parsec >= 3 && < 4
, parsec >=3 && <4
, 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 >=4.8 && <5
, containers
, data-fix
, haskeline
, parsec >= 3 && < 4
, lish
, parsec >=3 && <4
, pipes
, protolude
, pretty
, pretty-show
, process
, protolude
, text
, lish
default-language: Haskell2010
test-suite lish-benchmark
test-suite lish-doctest
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
Paths_lish
hs-source-dirs:
src-benchmark
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 >=3 && <4
, pipes
, protolude
, pretty
, pretty-show
, process
, protolude
, text
, lish
, base >= 4.8 && < 5
, criterion >= 1.1
default-language: Haskell2010
test-suite lish-doctest
test-suite lish-test
type: exitcode-stdio-1.0
main-is: Main.hs
hs-source-dirs:
src-doctest
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 >=3 && <4
, pipes
, protolude
, pretty
, pretty-show
, process
, protolude
, tasty >=0.11
, tasty-hunit >=0.9
, tasty-smallcheck >=0.8
, text
, lish
, base >= 4.8 && < 5
, doctest >=0.10
, Glob >= 0.7
, QuickCheck >= 2.5
other-modules:
Lish.Test.Parser
Paths_lish
default-language: Haskell2010
test-suite lish-test
benchmark lish-benchmark
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
Paths_lish
hs-source-dirs:
src-test
src-benchmark
ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >= 4.8 && < 5
base >=4.8 && <5
, containers
, criterion >=1.1
, data-fix
, haskeline
, parsec >= 3 && < 4
, lish
, parsec >=3 && <4
, 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
other-modules:
Lish.Test.Parser
, text
default-language: Haskell2010

@ -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)
[]

@ -0,0 +1 @@
import (fetchTarball https://github.com/NixOS/nixpkgs/archive/20.03.tar.gz) {}

@ -59,6 +59,7 @@ tests:
- doctest >=0.10
- Glob >= 0.7
- QuickCheck >= 2.5
benchmarks:
lish-benchmark:
source-dirs: src-benchmark
main: Main.hs

@ -0,0 +1,4 @@
let
def = import ./. {};
in
{ lish = def.lish; }

@ -0,0 +1 @@
(import ./. {}).shell

@ -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 ))))))))))))))))))))))))")
]

@ -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
]

@ -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]

@ -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

@ -46,7 +46,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

@ -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))
@ -86,13 +85,13 @@ _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)
@ -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)

@ -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)
@ -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,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
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
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)

@ -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

@ -25,15 +25,16 @@ 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)
data ExprF a = Atom Text
| Num Integer
| Bool Bool
| Str Text
| List [a]
| Lambda [a]
| Void
-- | Type representing an expression
data ExprF a = Atom Text -- ^ an atom is just a variable name
| Num Integer -- ^ a number
| Bool Bool -- ^ a boolean
| Str Text -- ^ a string
| List [a] -- ^ a list
| Lambda [a] -- ^ a function (lambda expression)
| Void -- ^ an empty value
-- only exists during evaluation
| Internal InternalCommand
| Fn { params :: [Text]
@ -67,11 +68,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 _) = "<stream>"
repr (WaitingStream _) = "<w-stream>"
@ -88,4 +89,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

@ -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: {}

@ -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.
stack build
# Run the binary
stack exec lish-exe
# Run the test suite.
stack test
# Run the benchmarks.
stack bench
# Generate documentation.
stack haddock
```
4. Customizing
==============
As you see, the template creates both a library and a binary and tests the
library using two test suites (doctests from comments and tests with Tasty).
Both test suites can test both properties and expected testcases. Finally,
the template also offers a way to benchmark the code.
Your project might differ significantly from this template. For example, you
might want to have a different number of executables. In that case, you should
remove/add more executable stanzas in `lish.cabal`.
Similarly, if you don't want both test suites, you can remove one of the
stanzas. You could do the same for the benchmarks.
*More importantly* you might want to change the contents of the library.
Rename `src/Lib` to whatever you want your top-module to be, usually the name
of your project but using `CamelCase`. Don't forget to change this name in all
places where it is referenced (executable(s), test(s) and benchmark(s)).
Thanks again, and happy hacking!
Loading…
Cancel
Save