Compare commits

...

16 Commits

22 changed files with 1189 additions and 311 deletions

1
.envrc Normal file
View File

@ -0,0 +1 @@
use flake

8
.gitignore vendored
View File

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

7
Notes.org Normal file
View File

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

View File

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

42
flake.lock Normal file
View File

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

38
flake.nix Normal file
View File

@ -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};
};
});
}

647
lish-benchmark.html Normal file

File diff suppressed because one or more lines are too long

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

98
tutorial.md Normal file
View File

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