From cc64fa01e9bae297915906a03f85fe50be384990 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 23 Nov 2019 15:59:08 -0800 Subject: Capitalize all Scheme and Haskell modules --- Com/Simatime/Bild.scm | 155 +++++++++++++++++++++ Com/Simatime/Core.scm | 158 +++++++++++++++++++++ Com/Simatime/Language/Bs.hs | 12 ++ Com/Simatime/Language/Bs/Cli.hs | 52 +++++++ Com/Simatime/Language/Bs/Eval.hs | 241 +++++++++++++++++++++++++++++++++ Com/Simatime/Language/Bs/Expr.hs | 154 +++++++++++++++++++++ Com/Simatime/Language/Bs/Parser.hs | 121 +++++++++++++++++ Com/Simatime/Language/Bs/Primitives.hs | 183 +++++++++++++++++++++++++ Com/Simatime/Language/Bs/Repl.hs | 33 +++++ Com/Simatime/Language/Bs/Test.hs | 2 + Com/Simatime/Repl.scm | 23 ++++ Com/Simatime/Shell.scm | 34 +++++ Com/Simatime/String.scm | 24 ++++ Com/Simatime/bild.scm | 155 --------------------- Com/Simatime/core.scm | 158 --------------------- Com/Simatime/language/Bs.hs | 12 -- Com/Simatime/language/Bs/Cli.hs | 52 ------- Com/Simatime/language/Bs/Eval.hs | 241 --------------------------------- Com/Simatime/language/Bs/Expr.hs | 154 --------------------- Com/Simatime/language/Bs/Parser.hs | 121 ----------------- Com/Simatime/language/Bs/Primitives.hs | 183 ------------------------- Com/Simatime/language/Bs/Repl.hs | 33 ----- Com/Simatime/language/Bs/Test.hs | 2 - Com/Simatime/repl.scm | 23 ---- Com/Simatime/shell.scm | 34 ----- Com/Simatime/string.scm | 24 ---- 26 files changed, 1192 insertions(+), 1192 deletions(-) create mode 100755 Com/Simatime/Bild.scm create mode 100644 Com/Simatime/Core.scm create mode 100644 Com/Simatime/Language/Bs.hs create mode 100644 Com/Simatime/Language/Bs/Cli.hs create mode 100644 Com/Simatime/Language/Bs/Eval.hs create mode 100644 Com/Simatime/Language/Bs/Expr.hs create mode 100644 Com/Simatime/Language/Bs/Parser.hs create mode 100644 Com/Simatime/Language/Bs/Primitives.hs create mode 100644 Com/Simatime/Language/Bs/Repl.hs create mode 100644 Com/Simatime/Language/Bs/Test.hs create mode 100644 Com/Simatime/Repl.scm create mode 100644 Com/Simatime/Shell.scm create mode 100644 Com/Simatime/String.scm delete mode 100755 Com/Simatime/bild.scm delete mode 100644 Com/Simatime/core.scm delete mode 100644 Com/Simatime/language/Bs.hs delete mode 100644 Com/Simatime/language/Bs/Cli.hs delete mode 100644 Com/Simatime/language/Bs/Eval.hs delete mode 100644 Com/Simatime/language/Bs/Expr.hs delete mode 100644 Com/Simatime/language/Bs/Parser.hs delete mode 100644 Com/Simatime/language/Bs/Primitives.hs delete mode 100644 Com/Simatime/language/Bs/Repl.hs delete mode 100644 Com/Simatime/language/Bs/Test.hs delete mode 100644 Com/Simatime/repl.scm delete mode 100644 Com/Simatime/shell.scm delete mode 100644 Com/Simatime/string.scm diff --git a/Com/Simatime/Bild.scm b/Com/Simatime/Bild.scm new file mode 100755 index 0000000..aa6fa94 --- /dev/null +++ b/Com/Simatime/Bild.scm @@ -0,0 +1,155 @@ +;; +;; bild - a simple build tool +;; +;;; Notice: +;; +;; This is under active development. For now this is just a convenience wrapper +;; around `nix build`. The below commentary describes how this tool *should* +;; work. +;; +;;; Commentary: +;; +;; Design constraints +;; +;; - only input is a namespace, no subcommands, no packages +;; - no need to write specific build rules +;; - one rule for hs, one for rs, one for scm, and so on +;; - no need to distinguish between exe and lib, just have a single output +;; - never concerned with deployment/packaging - leave that to another tool (scp? tar?)) +;; +;; Features +;; +;; - namespace maps to filesystem +;; - no need for `bild -l` for listing available targets. Use `ls` or `tree` +;; - you build namespaces, not files/modules/packages/etc +;; - namespace maps to language modules +;; - build settings can be set in the file comments +;; - pwd is always considered the the source directory, no `src` vs `doc` etc. +;; - build methods automaticatly detected with file extensions +;; - flags modify the way to interact with the build +;; - -s = jump into a shell and/or repl +;; - -p = turn on profiling +;; - -t = limit build by type +;; - -e = exclude some regex in the ns tree +;; - -o = optimize level +;; +;; Example Commands +;; +;; bild [-rpt] +;; +;; The general scheme is to build the things described by the targets. A target +;; is a namespace. You can list as many as you want, but you must list at least +;; one. It could just be `.` for the current directory. Build outputs will go +;; into the _bild directory in the root of the project. +;; +;; bild biz.web +;; +;; Or `bild biz/web`. This shows building a file at ./biz/web.hs, this will +;; translate to something like `ghc --make Biz.Web`. +;; +;; bild -r +;; +;; Starts a repl/shell for target. +;; - if target.hs, load ghci +;; - if target.scm, load scheme repl +;; - if target.clj, load a clojure repl +;; - if target.nix, load nix-shell +;; - and so on. +;; +;; bild -p +;; +;; build target with profiling (if available) +;; +;; bild -t nix target +;; +;; only build target.nix, not target.hs and so on (in the case of multiple +;; targets with the same name but different extension). +;; +;; Here is an example integration with GHC. Given the following command-line +;; invocation to compile the namespace 'com.simatime.bild' which depends on +;; 'com.simatime.lib': +;; +;; ghc com/simatime/bild.hs -i com/simatime/lib.hs -o _bild/bild -v \ +;; -main-is Com.Simatime.Bild.main +;; +;; The general template of which is: +;; +;; ghc -i -o -main-is .main +;; +;; Some definitions: +;; +;; - is some source file +;; - is the stack of dependencies +;; - is the target namespace, indicated by 'bild ' +;; +;; To fill out the build template, we can parse the file for known +;; namespaces. The general recipe is: +;; +;; 1. Create a list of namespaces in my git repo. This can be cached, or I can +;; integrate with git somehow. +;; 2. Read the file corresponding to +;; 3. Look for 'import ', where is a namespace in the +;; aforementioned cache. +;; 4. If found, then save current build as a continuation and compile +;; . Result gets put on the dependency stack +;; 5. When finished, return to building +;; +;; Once the build command template is filled out, we can create the nix expression. +;; +;; Questions +;; +;; - how to import (third-party) dependencies? +;; 1 just don't have them...? yeah right +;; 2 the target.nix could be the build description for target.hs +;; 3 just use a default.nix for the com.whatever +;; 4 have a deps.nix file +;; 5 list them in the file with other settings +;; - how to handle multiple output formats? +;; - e.g. that ghcjs and ghc take the same input files... +;; - say you have a .md file, you want to bild it to pdf, html, and more. What do? +;; - i guess the nix file could return a set of drvs instead of a single drv +;; +;; TODO +;; - stream output from 'nix build' subprocess +;; - get rid of guile notes during execution +;; - ns<->path macro +;; - support list (scheme namespace) in ns<->path fns +;; +;;; Code: + +(define-module (Com Simatime Bild) + #:use-module ((ice-9 popen) #:prefix popen/) + #:use-module ((ice-9 format) #:select (format)) + #:use-module ((ice-9 rdelim) #:prefix rdelim/) + #:use-module ((Com Simatime Core) #:select (fmt)) + #:use-module ((Com Simatime Shell) #:prefix sh/) + #:use-module ((Com Simatime String) #:prefix string/) + #:export (ns? + ns->path + path->ns + main)) + +(define (main args) + (let* ((root (sh/exec "git rev-parse --show-toplevel")) + (target (cadr args)) + (path (ns->path target))) + (display (fmt ":: bild ~a...\r" target)) + (sh/exec (fmt "nix build -f ~a/default.nix ~a" + root target)) + (display (fmt ":: bilt ~a" target)))) + +(define ns? symbol?) + +(define (ns->path ns) + (let ((to-path (lambda (s) (string/replace s #\. #\/)))) + (cond + ((symbol? ns) (to-path (symbol->string ns))) + ((string? ns) (to-path ns)) + (else (error "ns should be a string or symbol"))))) + +(define (path->ns path) + (let ((to-ns (lambda (s) (string/replace s #\/ #\.)))) + (cond + ((symbol? path) (to-ns (symbol->string path))) + ((string? path) (to-ns path)) + (else (error "path should be a string or symbol"))))) diff --git a/Com/Simatime/Core.scm b/Com/Simatime/Core.scm new file mode 100644 index 0000000..83ded5d --- /dev/null +++ b/Com/Simatime/Core.scm @@ -0,0 +1,158 @@ +(define-module (Com Simatime Core) + #:use-module ((ice-9 format)) + #:export ( + ;; simple printing + fmt printf pr prn + + ;; navigating data + first next second rest + + ;; booleans + true? false? nil nil? + + ;; dev helpers + comment + )) + +(define (flip f) (lambda (x y) (f y x))) +(define (curry f a) (lambda (b) (apply f (cons a (list b))))) +(define pos? + (curry < 0)) + +(define neg? + (curry > 0)) + +(define (foldr f end lst) + (if (null? lst) + end + (f (car lst) (foldr f end (cdr lst))))) + +(define (foldl f acc lst) + (if (null? lst) + acc + (foldl f (f acc (car lst)) (cdr lst)))) + +(define fold foldl) + +(define (unfold f init pred) + (if (pred init) + (cons init '()) + (cons init (unfold f (f init) pred)))) + +(define (sum lst) (fold + 0 lst)) +(define (produce lst) (fold * 1 lst)) + +(define count length) + + +;; +;; clojure-like stuff +;; + +(define (pr . a) + (for-each display a)) + +(define (prn . a) (apply pr a) (newline)) + +(define (first a) + "Return the first item in the collection." + (car a)) + +(define (rest a) + "Returns a list of the items after the first." + (cdr a)) + +(define (next a) + "Returns the next item after the first." + (cadr a)) + +;; same thing, easier to remember/read +(define second next) + +(define (ffirst a) + (first (first a))) + +(define (nnext a) + (next (next a))) + +(define (last coll) + "Return the last time in coll, in linear time." + (if (next coll) + (last coll) + (first coll))) + +(define (butlast ls) + "Return everthing execpt the last element in ls." + (let ((len (length ls))) + (list-head ls (- len 1)))) + +(define (false? x) + (eq? #f x)) + +(define (true? x) + (eq? #t x)) + +(define nil #nil) + +(define (nil? x) + (eq? nil x)) + +;; Ignores body, returns nil. +(define-syntax comment + (syntax-rules () + ((_ ...) nil))) + +(comment + ;; nil is different from null. nil is supposed to be more like + ;; 'Nothing' in Haskell, it is the absence of any value or type; + ;; whereas null is specifically the empty list, which still has a type + ;; of 'list'. + (null? '()) ;; => #t + (nil? '()) ;; => #f + ) + +(define (some pred coll) + (or (pred (first coll)) + (some pred (next coll)))) + +(define comp compose) + +(define (not-any? pred coll) + (comp not some)) + +(define (printf . args) + (display (apply format args))) + +(define-syntax fmt + (syntax-rules () + ((_ s args ...) + (format #f s args ...)))) + +;; If I implement ML-like interface abstractions in scheme, what would it look like? + +;; +;; ;; seq + +;; (define-class () (_first)) + +;; +;; ;; Functor + +;; (define-class ()) + +;; (define-method (fmap (f ) (coll ))) + +;; +;; ;; Applicative + +;; ;; a -> f a +;; (define-method (pure (a ))) + +;; ;; f (a -> b) -> f a -> f b +;; (define-method (<*> (f ) (a ) (b ))) + +;; ;; f a -> f b -> f b +;; (define-method (*> (a ) (b ))) + +;; ;; f a -> f b -> f a +;; (define-method (<* (a ) (b ))) diff --git a/Com/Simatime/Language/Bs.hs b/Com/Simatime/Language/Bs.hs new file mode 100644 index 0000000..a810706 --- /dev/null +++ b/Com/Simatime/Language/Bs.hs @@ -0,0 +1,12 @@ +-- https://github.com/write-you-a-scheme-v2/scheme +-- https://github.com/justinethier/husk-scheme +module Language.Bs + ( module X + ) where + +import Language.Bs.Cli as X +import Language.Bs.Eval as X +import Language.Bs.Expr as X +import Language.Bs.Parser as X +import Language.Bs.Primitives as X +import Language.Bs.Repl as X diff --git a/Com/Simatime/Language/Bs/Cli.hs b/Com/Simatime/Language/Bs/Cli.hs new file mode 100644 index 0000000..4c48c86 --- /dev/null +++ b/Com/Simatime/Language/Bs/Cli.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Cli ( + run +) where + +import Data.String +import Data.Text.IO as TIO +import Language.Bs.Eval -- evalFile :: T.Text -> IO () +import Language.Bs.Repl -- Repl.mainLoop :: IO () +import Options.Applicative +import Protolude +import System.Directory + +-- SOURCES +--http://book.realworldhaskell.org/read/io.html +-- https://github.com/pcapriotti/optparse-applicative +-- https://hackage.haskell.org/package/optparse-applicative + +runScript :: FilePath -> IO () +runScript fname = do + exists <- doesFileExist fname + if exists + then TIO.readFile fname >>= evalFile fname + else TIO.putStrLn "File does not exist." + +data LineOpts = UseReplLineOpts | RunScriptLineOpts String + +parseLineOpts :: Parser LineOpts +parseLineOpts = runScriptOpt <|> runReplOpt + where + runScriptOpt = + RunScriptLineOpts <$> strOption (long "script" + <> short 's' + <> metavar "SCRIPT" + <> help "File containing the script you want to run") + runReplOpt = + UseReplLineOpts <$ flag' () (long "repl" + <> short 'r' + <> help "Run as interavtive read/evaluate/print/loop") + +schemeEntryPoint :: LineOpts -> IO () +schemeEntryPoint UseReplLineOpts = mainLoop --repl +schemeEntryPoint (RunScriptLineOpts script) = runScript script + +run :: IO () +run = execParser opts >>= schemeEntryPoint + where + opts = info (helper <*> parseLineOpts) + ( fullDesc + <> header "Executable binary for Write You A Scheme v2.0" + <> progDesc "contains an entry point for both running scripts and repl" ) diff --git a/Com/Simatime/Language/Bs/Eval.hs b/Com/Simatime/Language/Bs/Eval.hs new file mode 100644 index 0000000..290170b --- /dev/null +++ b/Com/Simatime/Language/Bs/Eval.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Eval ( + evalText +, evalFile +, runParseTest +, safeExec +, runASTinEnv +, basicEnv +, fileToEvalForm +, textToEvalForm +, getFileContents +) where + +import Control.Exception +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.String +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Language.Bs.Expr +import Language.Bs.Parser +import Language.Bs.Primitives +import Protolude +import System.Directory + +funcEnv :: Map.Map T.Text Expr +funcEnv = Map.fromList $ primEnv + <> [ ("read" , IFun $ IFunc $ unop readFn) + , ("parse", IFun $ IFunc $ unop parseFn) + , ("eval", IFun $ IFunc $ unop eval) + , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) + ] + +basicEnv :: Env +basicEnv = Env Map.empty funcEnv + +readFn :: Expr -> Eval Expr +readFn (Tape txt) = lineToEvalForm txt +readFn val = throw $ TypeMismatch "read expects string, instead got:" val + +parseFn :: Expr -> Eval Expr +parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt +parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val + +safeExec :: IO a -> IO (Either String a) +safeExec m = do + result <- Control.Exception.try m + case result of + Left (eTop :: SomeException) -> + case fromException eTop of + Just (enclosed :: LispError) -> + return $ Left (show enclosed) + Nothing -> + return $ Left (show eTop) + Right val -> + return $ Right val + +runASTinEnv :: Env -> Eval b -> IO b +runASTinEnv code action = runReaderT (unEval action) code + +lineToEvalForm :: T.Text -> Eval Expr +lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input + +evalFile :: FilePath -> T.Text -> IO () -- program file +evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print + +fileToEvalForm :: FilePath -> T.Text -> Eval Expr +fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input + +runParseTest :: T.Text -> T.Text -- for view AST +runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input + +getFileContents :: FilePath -> IO T.Text +getFileContents fname = do + exists <- doesFileExist fname + if exists then TIO.readFile fname else return "File does not exist." + +textToEvalForm :: T.Text -> Eval Expr +textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input + +evalText :: T.Text -> IO () --REPL +evalText textExpr = do + res <- runASTinEnv basicEnv $ textToEvalForm textExpr + print res + +getVar :: Expr -> Eval Expr +getVar (Atom atom) = do + Env{..} <- ask + case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions + Just x -> return x + Nothing -> throw $ UnboundVar atom +getVar n = throw $ TypeMismatch "failure to get variable: " n + +ensureAtom :: Expr -> Eval Expr +ensureAtom n@(Atom _) = return n +ensureAtom n@(List _) = throw $ TypeMismatch "got list" n +ensureAtom n = throw $ TypeMismatch "expected an atomic value" n + +extractVar :: Expr -> T.Text +extractVar (Atom atom) = atom +extractVar n = throw $ TypeMismatch "expected an atomic value" n + +getEven :: [t] -> [t] +getEven [] = [] +getEven (x:xs) = x : getOdd xs + +getOdd :: [t] -> [t] +getOdd [] = [] +getOdd (_:xs) = getEven xs + +applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr +applyFunc expr params args = bindArgsEval params args expr + +bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr +bindArgsEval params args expr = do + Env{..} <- ask + let newVars = zipWith (\a b -> (extractVar a,b)) params args + let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars + local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr + +isFunc :: Expr -> Bool +isFunc (List ((Atom "lambda"):_)) = True +isFunc _ = False + +eval :: Expr -> Eval Expr +eval (List [Atom "dumpEnv", x]) = do + Env{..} <- ask + liftIO $ print $ toList env + liftIO $ print $ toList fenv + eval x + +eval (Numb i) = return $ Numb i +eval (Tape s) = return $ Tape s +eval (Bool b) = return $ Bool b +eval (List []) = return Nil +eval Nil = return Nil +eval n@(Atom _) = getVar n + +eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest +eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest + +eval (List [Atom "quote", val]) = return val + +eval (List [Atom "if", pred_, then_, else_]) = do + ifRes <- eval pred_ + case ifRes of + (Bool True) -> eval then_ + (Bool False) -> eval else_ + _ -> + throw $ BadSpecialForm "if's first arg must eval into a boolean" +eval (List ( (:) (Atom "if") _)) = + throw $ BadSpecialForm "(if )" + +eval (List [Atom "begin", rest]) = evalBody rest +eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest + +-- top-level define +-- TODO: how to make this eval correctly? +eval (List [Atom "define", List (name:args), body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval (name:args) [body] name + +eval (List [Atom "define", name, body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval [name] [body] name + +eval (List [Atom "let", List pairs, expr]) = do + Env{..} <- ask + atoms <- mapM ensureAtom $ getEven pairs + vals <- mapM eval $ getOdd pairs + bindArgsEval atoms vals expr + +eval (List (Atom "let":_) ) = + throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" + + +eval (List [Atom "lambda", List params, expr]) = do + ctx <- ask + return $ Func (IFunc $ applyFunc expr params) ctx +eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" + + +-- needed to get cadr, etc to work +eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) = + return $ List xs +eval (List [Atom "cdr", arg@(List (x:xs))]) = + case x of + -- proxy for if the list can be evaluated + Atom _ -> do + val <- eval arg + eval $ List [Atom "cdr", val] + _ -> return $ List xs + + +eval (List [Atom "car", List [Atom "quote", List (x:_)]]) = + return $ x +eval (List [Atom "car", arg@(List (x:_))]) = + case x of + Atom _ -> do + val <- eval arg + eval $ List [Atom "car", val] + _ -> return $ x + + +eval (List ((:) x xs)) = do + Env{..} <- ask + funVar <- eval x + xVal <- mapM eval xs + case funVar of + (IFun (IFunc internalFn)) -> + internalFn xVal + + (Func (IFunc definedFn) (Env benv _)) -> + local (const $ Env benv fenv) $ definedFn xVal + + _ -> + throw $ NotFunction funVar + +updateEnv :: T.Text -> Expr -> Env -> Env +updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e Env{..} = Env (Map.insert var e env) fenv + +evalBody :: Expr -> Eval Expr +evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ eval rest + +evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest + +evalBody x = eval x diff --git a/Com/Simatime/Language/Bs/Expr.hs b/Com/Simatime/Language/Bs/Expr.hs new file mode 100644 index 0000000..a39c7b6 --- /dev/null +++ b/Com/Simatime/Language/Bs/Expr.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Language.Bs.Expr where + +import Data.String (String) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Show +import Protolude hiding (show) +import qualified Text.PrettyPrint.Leijen.Text as PP +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +type Ctx = Map Text Expr +data Env = Env { env :: Ctx, fenv :: Ctx } + deriving (Eq) + +newtype Eval a = Eval { unEval :: ReaderT Env IO a } + deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO) + +data IFunc = IFunc { fn :: [Expr] -> Eval Expr } + deriving (Typeable) + +instance Eq IFunc where + (==) _ _ = False + +data Expr + = Atom Text + | List [Expr] + | Numb Integer + | Tape Text + | IFun IFunc -- TODO: call this Kern + | Func IFunc Env + | Bool Bool + | Nil + deriving (Typeable, Eq) + +instance Show Expr where + show = T.unpack . ppexpr + +data LispErrorType + = NumArgs Integer [Expr] + | LengthOfList Text Int + | ExpectedList Text + | ParseError String + | TypeMismatch Text Expr + | BadSpecialForm Text + | NotFunction Expr + | UnboundVar Text + | Default Expr + | ReadFileError Text + deriving (Typeable) + +data LispError = LispError Expr LispErrorType + +instance Show LispErrorType where + show = T.unpack . ppexpr + +instance Show LispError where + show = T.unpack . ppexpr + +instance Exception LispErrorType +instance Exception LispError + +ppexpr :: Pretty a => a -> Text +ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) + +--prettyList :: [Doc] -> Doc +--prettyList = encloseSep lparen rparen PP.space + +instance Pretty Expr where + pretty v = + case v of + Atom a -> + textStrict a + + List ls -> + prettyList $ fmap pretty ls + + Numb n -> + integer n + + Tape t -> + textStrict "\"" <> textStrict t <> textStrict "\"" + + IFun _ -> + textStrict "" + + Func _ _ -> + textStrict "" + + Bool True -> + textStrict "#t" + + Bool False -> + textStrict "#f" + + Nil -> + textStrict "'()" + +instance Pretty LispErrorType where + pretty err = case err of + NumArgs i args -> + textStrict "number of arguments" + <$$> textStrict "expected" + <+> textStrict (T.pack $ show i) + <$$> textStrict "received" + <+> textStrict (T.pack $ show $ length args) + + + LengthOfList txt i -> + textStrict "length of list in:" + <+> textStrict txt + <$$> textStrict "length:" + <+> textStrict (T.pack $ show i) + + ParseError txt -> + textStrict "cannot parse expr:" + <+> textStrict (T.pack txt) + + TypeMismatch txt expr -> + textStrict "type mismatch:" + <$$> textStrict txt + <$$> pretty expr + + BadSpecialForm txt -> + textStrict "bad special form:" + <$$> textStrict txt + + NotFunction expr -> + textStrict "not a function" + <$$> pretty expr + + UnboundVar txt -> + textStrict "unbound variable:" + <$$> textStrict txt + + Default _ -> + textStrict "default error" + + ReadFileError txt -> + textStrict "error reading file:" + <$$> textStrict txt + + ExpectedList txt -> + textStrict "expected list:" + <$$> textStrict txt + +instance Pretty LispError where + pretty (LispError expr typ) = + textStrict "error evaluating:" + <$$> indent 4 (pretty expr) + <$$> pretty typ diff --git a/Com/Simatime/Language/Bs/Parser.hs b/Com/Simatime/Language/Bs/Parser.hs new file mode 100644 index 0000000..3044a60 --- /dev/null +++ b/Com/Simatime/Language/Bs/Parser.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Parser ( + readExpr +, readExprFile +) where + +import Control.Monad (fail) +import Control.Monad (mzero) +import Data.Char (digitToInt) +import Data.Functor.Identity (Identity) +import Data.String +import qualified Data.Text as T +import Language.Bs.Expr +import Protolude hiding ((<|>), try) +import Text.Parsec +import qualified Text.Parsec.Language as Lang +import Text.Parsec.Text +import qualified Text.Parsec.Token as Tok + +lexer :: Tok.GenTokenParser T.Text () Identity +lexer = Tok.makeTokenParser style + +style :: Tok.GenLanguageDef T.Text () Identity +style = Lang.emptyDef { + Tok.commentStart = "#|" + , Tok.commentEnd = "|#" + , Tok.commentLine = ";" + , Tok.opStart = mzero + , Tok.opLetter = mzero + , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~" + , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@" + } + +parens :: Parser a -> Parser a +parens = Tok.parens lexer + +whitespace :: Parser () +whitespace = Tok.whiteSpace lexer + +lexeme :: Parser a -> Parser a +lexeme = Tok.lexeme lexer + +quoted :: Parser a -> Parser a +quoted p = try (char '\'') *> p + +identifier :: Parser T.Text +identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) "identifier" + where + specialIdentifier :: Parser String + specialIdentifier = lexeme $ try $ + string "-" <|> string "+" <|> string "..." + +-- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for +-- digits in that base (e.g. @digit@). +type Radix = (Integer, Parser Char) + +-- | Parse an integer, given a radix as output by @radix@. +-- Copied from Text.Parsec.Token +numberWithRadix :: Radix -> Parser Integer +numberWithRadix (base, baseDigit) = do + digits <- many1 baseDigit + let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + seq n (return n) + +decimal :: Parser Integer +decimal = Tok.decimal lexer + +-- | Parse a sign, return either @id@ or @negate@ based on the sign parsed. +-- Copied from Text.Parsec.Token +sign :: Parser (Integer -> Integer) +sign = char '-' *> return negate + <|> char '+' *> return identity + <|> return identity + +intRadix :: Radix -> Parser Integer +intRadix r = sign <*> numberWithRadix r + +textLiteral :: Parser T.Text +textLiteral = T.pack <$> Tok.stringLiteral lexer + +nil :: Parser () +nil = try ((char '\'') *> string "()") *> return () "nil" + +hashVal :: Parser Expr +hashVal = lexeme $ char '#' + *> (char 't' *> return (Bool True) + <|> char 'f' *> return (Bool False) + <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01")) + <|> char 'o' *> (Numb <$> intRadix (8, octDigit)) + <|> char 'd' *> (Numb <$> intRadix (10, digit)) + <|> char 'x' *> (Numb <$> intRadix (16, hexDigit)) + <|> oneOf "ei" *> fail "Unsupported: exactness" + <|> char '(' *> fail "Unsupported: vector" + <|> char '\\' *> fail "Unsupported: char") + + +lispVal :: Parser Expr +lispVal = hashVal + <|> Nil <$ nil + <|> Numb <$> try (sign <*> decimal) + <|> Atom <$> identifier + <|> Tape <$> textLiteral + <|> _Quote <$> quoted lispVal + <|> List <$> parens manyExpr + +manyExpr :: Parser [Expr] +manyExpr = lispVal `sepBy` whitespace + +_Quote :: Expr -> Expr +_Quote x = List [Atom "quote", x] + +contents :: Parser a -> ParsecT T.Text () Identity a +contents p = whitespace *> lexeme p <* eof + +readExpr :: T.Text -> Either ParseError Expr +readExpr = parse (contents lispVal) "" + +readExprFile :: SourceName -> T.Text -> Either ParseError Expr +readExprFile = parse (contents (List <$> manyExpr)) diff --git a/Com/Simatime/Language/Bs/Primitives.hs b/Com/Simatime/Language/Bs/Primitives.hs new file mode 100644 index 0000000..c074c59 --- /dev/null +++ b/Com/Simatime/Language/Bs/Primitives.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | bs primitives +-- +-- I would like to reduce the number of primitives in the language to some +-- minimal number, like SKI combinator or Nock instructions. I'm not sure what +-- the minimal number is. The idea is to move primitives from here into core.scm +-- over time. +module Language.Bs.Primitives where + +import Control.Exception +import Control.Monad.Except +import Data.Text as T +import Data.Text.IO as TIO +import Language.Bs.Expr +import Network.HTTP +import Protolude +import System.Directory +import System.IO + +type Prim = [(T.Text, Expr)] +type Unary = Expr -> Eval Expr +type Binary = Expr -> Expr -> Eval Expr + +mkF :: ([Expr] -> Eval Expr) -> Expr +mkF = IFun . IFunc + +primEnv :: Prim +primEnv = [ + ("+" , mkF $ binopFold (numOp (+)) (Numb 0) ) + , ("*" , mkF $ binopFold (numOp (*)) (Numb 1) ) + , ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") ) + , ("-" , mkF $ binop $ numOp (-)) + , ("<" , mkF $ binop $ numCmp (<)) + , ("<=" , mkF $ binop $ numCmp (<=)) + , (">" , mkF $ binop $ numCmp (>)) + , (">=" , mkF $ binop $ numCmp (>=)) + , ("==" , mkF $ binop $ numCmp (==)) + , ("even?" , mkF $ unop $ numBool even) + , ("odd?" , mkF $ unop $ numBool odd) + , ("neg?" , mkF $ unop $ numBool (< 0)) + , ("pos?" , mkF $ unop $ numBool (> 0)) + , ("eq?" , mkF $ binop eqCmd ) + , ("null?" , mkF $ unop (eqCmd Nil) ) + , ("bl-eq?" , mkF $ binop $ eqOp (==)) + , ("and" , mkF $ binopFold (eqOp (&&)) (Bool True)) + , ("or" , mkF $ binopFold (eqOp (||)) (Bool False)) + , ("not" , mkF $ unop $ notOp) + , ("cons" , mkF $ Language.Bs.Primitives.cons) + , ("cdr" , mkF $ Language.Bs.Primitives.cdr) + , ("car" , mkF $ Language.Bs.Primitives.car) + , ("quote" , mkF $ quote) + , ("file?" , mkF $ unop fileExists) + , ("slurp" , mkF $ unop slurp) + , ("wslurp" , mkF $ unop wSlurp) + , ("put" , mkF $ binop put_) + ] + +unop :: Unary -> [Expr] -> Eval Expr +unop op [x] = op x +unop _ args = throw $ NumArgs 1 args + +binop :: Binary -> [Expr] -> Eval Expr +binop op [x,y] = op x y +binop _ args = throw $ NumArgs 2 args + +fileExists :: Expr -> Eval Expr +fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) +fileExists val = throw $ TypeMismatch "read expects string, instead got: " val + +slurp :: Expr -> Eval Expr +slurp (Tape txt) = liftIO $ wFileSlurp txt +slurp val = throw $ TypeMismatch "read expects string, instead got: " val + +wFileSlurp :: T.Text -> IO Expr +wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go + where go = readTextFile fileName + +openURL :: T.Text -> IO Expr +openURL x = do + req <- simpleHTTP (getRequest $ T.unpack x) + body <- getResponseBody req + return $ Tape $ T.pack body + +wSlurp :: Expr -> Eval Expr +wSlurp (Tape txt) = liftIO $ openURL txt +wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val + +readTextFile :: T.Text -> Handle -> IO Expr +readTextFile fileName h = do + exists <- doesFileExist $ T.unpack fileName + if exists + then (TIO.hGetContents h) >>= (return . Tape) + else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] + +put_ :: Expr -> Expr -> Eval Expr +put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg +put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val +put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val + +wFilePut :: T.Text -> T.Text -> IO Expr +wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go + where go = putTextFile fileName msg + +putTextFile :: T.Text -> T.Text -> Handle -> IO Expr +putTextFile fileName msg h = do + canWrite <- hIsWritable h + if canWrite + then (TIO.hPutStr h msg) >> (return $ Tape msg) + else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] + +binopFold :: Binary -> Expr -> [Expr] -> Eval Expr +binopFold op farg args = case args of + []-> throw $ NumArgs 2 args + [a,b] -> op a b + _ -> foldM op farg args + +numBool :: (Integer -> Bool) -> Expr -> Eval Expr +numBool op (Numb x) = return $ Bool $ op x +numBool _ x = throw $ TypeMismatch "numeric op " x + +numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr +numOp op (Numb x) (Numb y) = return $ Numb $ op x y +numOp _ Nil (Numb y) = return $ Numb y +numOp _ (Numb x) Nil = return $ Numb x +numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x +numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y +numOp _ x _ = throw $ TypeMismatch "numeric op" x + +strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr +strOp op (Tape x) (Tape y) = return $ Tape $ op x y +strOp _ Nil (Tape y) = return $ Tape y +strOp _ (Tape x) Nil = return $ Tape x +strOp _ x (Tape _) = throw $ TypeMismatch "string op" x +strOp _ (Tape _) y = throw $ TypeMismatch "string op" y +strOp _ x _ = throw $ TypeMismatch "string op" x + +eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr +eqOp op (Bool x) (Bool y) = return $ Bool $ op x y +eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x +eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y +eqOp _ x _ = throw $ TypeMismatch "bool op" x + +numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr +numCmp op (Numb x) (Numb y) = return . Bool $ op x y +numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x +numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y +numCmp _ x _ = throw $ TypeMismatch "numeric op" x + +notOp :: Expr -> Eval Expr +notOp (Bool True) = return $ Bool False +notOp (Bool False) = return $ Bool True +notOp x = throw $ TypeMismatch " not expects Bool" x + +eqCmd :: Expr -> Expr -> Eval Expr +eqCmd (Atom x) (Atom y) = return . Bool $ x == y +eqCmd (Numb x) (Numb y) = return . Bool $ x == y +eqCmd (Tape x) (Tape y) = return . Bool $ x == y +eqCmd (Bool x) (Bool y) = return . Bool $ x == y +eqCmd Nil Nil = return $ Bool True +eqCmd _ _ = return $ Bool False + +cons :: [Expr] -> Eval Expr +cons [x,(List ys)] = return $ List $ x:ys +cons [x,y] = return $ List [x,y] +cons _ = throw $ ExpectedList "cons, in second argument" + +car :: [Expr] -> Eval Expr +car [List [] ] = return Nil +car [List (x:_)] = return x +car [] = return Nil +car _ = throw $ ExpectedList "car" + +cdr :: [Expr] -> Eval Expr +cdr [List (_:xs)] = return $ List xs +cdr [List []] = return Nil +cdr [] = return Nil +cdr _ = throw $ ExpectedList "cdr" + +quote :: [Expr] -> Eval Expr +quote [List xs] = return $ List $ Atom "quote" : xs +quote [expr] = return $ List $ Atom "quote" : [expr] +quote args = throw $ NumArgs 1 args diff --git a/Com/Simatime/Language/Bs/Repl.hs b/Com/Simatime/Language/Bs/Repl.hs new file mode 100644 index 0000000..64ffaa2 --- /dev/null +++ b/Com/Simatime/Language/Bs/Repl.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.Bs.Repl ( +mainLoop +) where + +import Control.Monad.Trans +import Data.String +import Data.Text as T +import Language.Bs.Eval +import Protolude +import System.Console.Haskeline + +type Repl a = InputT IO a + +mainLoop :: IO () +mainLoop = runInputT defaultSettings repl + +repl :: Repl () +repl = do + minput <- getInputLine "bs> " + case minput of + Nothing -> outputStrLn "bye." + Just input -> (liftIO $ process input) >> repl + --Just input -> (liftIO $ processToAST input) >> repl + +process :: String -> IO () +process str = do + res <- safeExec $ evalText $ T.pack str + either putStrLn return res + +processToAST :: String -> IO () +processToAST str = print $ runParseTest $ T.pack str diff --git a/Com/Simatime/Language/Bs/Test.hs b/Com/Simatime/Language/Bs/Test.hs new file mode 100644 index 0000000..4a40036 --- /dev/null +++ b/Com/Simatime/Language/Bs/Test.hs @@ -0,0 +1,2 @@ +-- TODO +module Language.Bs.Test where diff --git a/Com/Simatime/Repl.scm b/Com/Simatime/Repl.scm new file mode 100644 index 0000000..af9a494 --- /dev/null +++ b/Com/Simatime/Repl.scm @@ -0,0 +1,23 @@ +(define-module (Com Simatime Repl) + #:export ()) + + +;; +;; repl customization +;; + +;; (use-modules (system repl common)) +;; (repl-default-option-set! +;; 'prompt +;; (lambda (repl) +;; (format #f "\n[~a@~a:~a]\nλ> " +;; (getenv "USER") +;; (vector-ref (uname) 1) +;; (pwd)))) + +;; TODO(bsima): (doc x) +;; TODO(bsima): (src x) +;; TODO(bsima): ,src command +;; TODO(bsima): ,shell command +;; TODO(bsima): how to load this file on startup? +;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl diff --git a/Com/Simatime/Shell.scm b/Com/Simatime/Shell.scm new file mode 100644 index 0000000..b99e5cd --- /dev/null +++ b/Com/Simatime/Shell.scm @@ -0,0 +1,34 @@ +(define-module (Com Simatime Shell) + #:use-module ((ice-9 popen) #:prefix popen/) + #:use-module ((ice-9 rdelim) #:prefix rdelim/) + #:use-module ((ice-9 ftw) #:prefix ftw/) + #:export (exec + stream + pwd + ls + cd)) + +(define (exec cmd) + (let* ((port (popen/open-input-pipe cmd)) + (ret (read port))) + (popen/close-pipe port) + ret)) + +(define (stream cmd) + (let* ((port (popen/open-input-pipe cmd)) + (_ (setvbuf port 'none)) + (ret (rdelim/read-string port))) + (flush-all-ports) + (popen/close-pipe port) + ret)) + +(define (pwd) + (regexp-substitute/global + #f "/home/ben" (getcwd) 'pre "~" 'post)) + +(define (ls) + (ftw/scandir (getcwd))) + +(define (cd path) + (chdir path) + (ls)) diff --git a/Com/Simatime/String.scm b/Com/Simatime/String.scm new file mode 100644 index 0000000..770b04b --- /dev/null +++ b/Com/Simatime/String.scm @@ -0,0 +1,24 @@ +(define-module (Com Simatime String) + #:export (replace to-string str capitalize)) + +(define (replace s match repl) + (let ((f (lambda (a b) + (let ((next-char (if (eq? a match) repl a))) + (string-concatenate (list b (string next-char))))))) + (string-fold f "" s))) + +(define (to-string x) + (format #f "~a" x)) + +(define str + (case-lambda + (() "") + ((x) (to-string x)) + ((x . rest) (string-concatenate (map str (cons x rest)))))) + +(define (capitalize s) + (let ((s (to-string s))) + (if (< (string-length s) 2) + (string-upcase s) + (str (string-upcase (substring s 0 1)) + (substring s 1 ))))) diff --git a/Com/Simatime/bild.scm b/Com/Simatime/bild.scm deleted file mode 100755 index c7ab666..0000000 --- a/Com/Simatime/bild.scm +++ /dev/null @@ -1,155 +0,0 @@ -;; -;; bild - a simple build tool -;; -;;; Notice: -;; -;; This is under active development. For now this is just a convenience wrapper -;; around `nix build`. The below commentary describes how this tool *should* -;; work. -;; -;;; Commentary: -;; -;; Design constraints -;; -;; - only input is a namespace, no subcommands, no packages -;; - no need to write specific build rules -;; - one rule for hs, one for rs, one for scm, and so on -;; - no need to distinguish between exe and lib, just have a single output -;; - never concerned with deployment/packaging - leave that to another tool (scp? tar?)) -;; -;; Features -;; -;; - namespace maps to filesystem -;; - no need for `bild -l` for listing available targets. Use `ls` or `tree` -;; - you build namespaces, not files/modules/packages/etc -;; - namespace maps to language modules -;; - build settings can be set in the file comments -;; - pwd is always considered the the source directory, no `src` vs `doc` etc. -;; - build methods automaticatly detected with file extensions -;; - flags modify the way to interact with the build -;; - -s = jump into a shell and/or repl -;; - -p = turn on profiling -;; - -t = limit build by type -;; - -e = exclude some regex in the ns tree -;; - -o = optimize level -;; -;; Example Commands -;; -;; bild [-rpt] -;; -;; The general scheme is to build the things described by the targets. A target -;; is a namespace. You can list as many as you want, but you must list at least -;; one. It could just be `.` for the current directory. Build outputs will go -;; into the _bild directory in the root of the project. -;; -;; bild biz.web -;; -;; Or `bild biz/web`. This shows building a file at ./biz/web.hs, this will -;; translate to something like `ghc --make Biz.Web`. -;; -;; bild -r -;; -;; Starts a repl/shell for target. -;; - if target.hs, load ghci -;; - if target.scm, load scheme repl -;; - if target.clj, load a clojure repl -;; - if target.nix, load nix-shell -;; - and so on. -;; -;; bild -p -;; -;; build target with profiling (if available) -;; -;; bild -t nix target -;; -;; only build target.nix, not target.hs and so on (in the case of multiple -;; targets with the same name but different extension). -;; -;; Here is an example integration with GHC. Given the following command-line -;; invocation to compile the namespace 'com.simatime.bild' which depends on -;; 'com.simatime.lib': -;; -;; ghc com/simatime/bild.hs -i com/simatime/lib.hs -o _bild/bild -v \ -;; -main-is Com.Simatime.Bild.main -;; -;; The general template of which is: -;; -;; ghc -i -o -main-is .main -;; -;; Some definitions: -;; -;; - is some source file -;; - is the stack of dependencies -;; - is the target namespace, indicated by 'bild ' -;; -;; To fill out the build template, we can parse the file for known -;; namespaces. The general recipe is: -;; -;; 1. Create a list of namespaces in my git repo. This can be cached, or I can -;; integrate with git somehow. -;; 2. Read the file corresponding to -;; 3. Look for 'import ', where is a namespace in the -;; aforementioned cache. -;; 4. If found, then save current build as a continuation and compile -;; . Result gets put on the dependency stack -;; 5. When finished, return to building -;; -;; Once the build command template is filled out, we can create the nix expression. -;; -;; Questions -;; -;; - how to import (third-party) dependencies? -;; 1 just don't have them...? yeah right -;; 2 the target.nix could be the build description for target.hs -;; 3 just use a default.nix for the com.whatever -;; 4 have a deps.nix file -;; 5 list them in the file with other settings -;; - how to handle multiple output formats? -;; - e.g. that ghcjs and ghc take the same input files... -;; - say you have a .md file, you want to bild it to pdf, html, and more. What do? -;; - i guess the nix file could return a set of drvs instead of a single drv -;; -;; TODO -;; - stream output from 'nix build' subprocess -;; - get rid of guile notes during execution -;; - ns<->path macro -;; - support list (scheme namespace) in ns<->path fns -;; -;;; Code: - -(define-module (Com Simatime bild) - #:use-module ((ice-9 popen) #:prefix popen/) - #:use-module ((ice-9 format) #:select (format)) - #:use-module ((ice-9 rdelim) #:prefix rdelim/) - #:use-module ((Com Simatime core) #:select (fmt)) - #:use-module ((Com Simatime shell) #:prefix sh/) - #:use-module ((Com Simatime string) #:prefix string/) - #:export (ns? - ns->path - path->ns - main)) - -(define (main args) - (let* ((root (sh/exec "git rev-parse --show-toplevel")) - (target (cadr args)) - (path (ns->path target))) - (display (fmt ":: bild ~a...\r" target)) - (sh/exec (fmt "nix build -f ~a/default.nix ~a" - root target)) - (display (fmt ":: bilt ~a" target)))) - -(define ns? symbol?) - -(define (ns->path ns) - (let ((to-path (lambda (s) (string/replace s #\. #\/)))) - (cond - ((symbol? ns) (to-path (symbol->string ns))) - ((string? ns) (to-path ns)) - (else (error "ns should be a string or symbol"))))) - -(define (path->ns path) - (let ((to-ns (lambda (s) (string/replace s #\/ #\.)))) - (cond - ((symbol? path) (to-ns (symbol->string path))) - ((string? path) (to-ns path)) - (else (error "path should be a string or symbol"))))) diff --git a/Com/Simatime/core.scm b/Com/Simatime/core.scm deleted file mode 100644 index 91d9339..0000000 --- a/Com/Simatime/core.scm +++ /dev/null @@ -1,158 +0,0 @@ -(define-module (Com Simatime core) - #:use-module ((ice-9 format)) - #:export ( - ;; simple printing - fmt printf pr prn - - ;; navigating data - first next second rest - - ;; booleans - true? false? nil nil? - - ;; dev helpers - comment - )) - -(define (flip f) (lambda (x y) (f y x))) -(define (curry f a) (lambda (b) (apply f (cons a (list b))))) -(define pos? - (curry < 0)) - -(define neg? - (curry > 0)) - -(define (foldr f end lst) - (if (null? lst) - end - (f (car lst) (foldr f end (cdr lst))))) - -(define (foldl f acc lst) - (if (null? lst) - acc - (foldl f (f acc (car lst)) (cdr lst)))) - -(define fold foldl) - -(define (unfold f init pred) - (if (pred init) - (cons init '()) - (cons init (unfold f (f init) pred)))) - -(define (sum lst) (fold + 0 lst)) -(define (produce lst) (fold * 1 lst)) - -(define count length) - - -;; -;; clojure-like stuff -;; - -(define (pr . a) - (for-each display a)) - -(define (prn . a) (apply pr a) (newline)) - -(define (first a) - "Return the first item in the collection." - (car a)) - -(define (rest a) - "Returns a list of the items after the first." - (cdr a)) - -(define (next a) - "Returns the next item after the first." - (cadr a)) - -;; same thing, easier to remember/read -(define second next) - -(define (ffirst a) - (first (first a))) - -(define (nnext a) - (next (next a))) - -(define (last coll) - "Return the last time in coll, in linear time." - (if (next coll) - (last coll) - (first coll))) - -(define (butlast ls) - "Return everthing execpt the last element in ls." - (let ((len (length ls))) - (list-head ls (- len 1)))) - -(define (false? x) - (eq? #f x)) - -(define (true? x) - (eq? #t x)) - -(define nil #nil) - -(define (nil? x) - (eq? nil x)) - -;; Ignores body, returns nil. -(define-syntax comment - (syntax-rules () - ((_ ...) nil))) - -(comment - ;; nil is different from null. nil is supposed to be more like - ;; 'Nothing' in Haskell, it is the absence of any value or type; - ;; whereas null is specifically the empty list, which still has a type - ;; of 'list'. - (null? '()) ;; => #t - (nil? '()) ;; => #f - ) - -(define (some pred coll) - (or (pred (first coll)) - (some pred (next coll)))) - -(define comp compose) - -(define (not-any? pred coll) - (comp not some)) - -(define (printf . args) - (display (apply format args))) - -(define-syntax fmt - (syntax-rules () - ((_ s args ...) - (format #f s args ...)))) - -;; If I implement ML-like interface abstractions in scheme, what would it look like? - -;; -;; ;; seq - -;; (define-class () (_first)) - -;; -;; ;; Functor - -;; (define-class ()) - -;; (define-method (fmap (f ) (coll ))) - -;; -;; ;; Applicative - -;; ;; a -> f a -;; (define-method (pure (a ))) - -;; ;; f (a -> b) -> f a -> f b -;; (define-method (<*> (f ) (a ) (b ))) - -;; ;; f a -> f b -> f b -;; (define-method (*> (a ) (b ))) - -;; ;; f a -> f b -> f a -;; (define-method (<* (a ) (b ))) diff --git a/Com/Simatime/language/Bs.hs b/Com/Simatime/language/Bs.hs deleted file mode 100644 index a810706..0000000 --- a/Com/Simatime/language/Bs.hs +++ /dev/null @@ -1,12 +0,0 @@ --- https://github.com/write-you-a-scheme-v2/scheme --- https://github.com/justinethier/husk-scheme -module Language.Bs - ( module X - ) where - -import Language.Bs.Cli as X -import Language.Bs.Eval as X -import Language.Bs.Expr as X -import Language.Bs.Parser as X -import Language.Bs.Primitives as X -import Language.Bs.Repl as X diff --git a/Com/Simatime/language/Bs/Cli.hs b/Com/Simatime/language/Bs/Cli.hs deleted file mode 100644 index 4c48c86..0000000 --- a/Com/Simatime/language/Bs/Cli.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Cli ( - run -) where - -import Data.String -import Data.Text.IO as TIO -import Language.Bs.Eval -- evalFile :: T.Text -> IO () -import Language.Bs.Repl -- Repl.mainLoop :: IO () -import Options.Applicative -import Protolude -import System.Directory - --- SOURCES ---http://book.realworldhaskell.org/read/io.html --- https://github.com/pcapriotti/optparse-applicative --- https://hackage.haskell.org/package/optparse-applicative - -runScript :: FilePath -> IO () -runScript fname = do - exists <- doesFileExist fname - if exists - then TIO.readFile fname >>= evalFile fname - else TIO.putStrLn "File does not exist." - -data LineOpts = UseReplLineOpts | RunScriptLineOpts String - -parseLineOpts :: Parser LineOpts -parseLineOpts = runScriptOpt <|> runReplOpt - where - runScriptOpt = - RunScriptLineOpts <$> strOption (long "script" - <> short 's' - <> metavar "SCRIPT" - <> help "File containing the script you want to run") - runReplOpt = - UseReplLineOpts <$ flag' () (long "repl" - <> short 'r' - <> help "Run as interavtive read/evaluate/print/loop") - -schemeEntryPoint :: LineOpts -> IO () -schemeEntryPoint UseReplLineOpts = mainLoop --repl -schemeEntryPoint (RunScriptLineOpts script) = runScript script - -run :: IO () -run = execParser opts >>= schemeEntryPoint - where - opts = info (helper <*> parseLineOpts) - ( fullDesc - <> header "Executable binary for Write You A Scheme v2.0" - <> progDesc "contains an entry point for both running scripts and repl" ) diff --git a/Com/Simatime/language/Bs/Eval.hs b/Com/Simatime/language/Bs/Eval.hs deleted file mode 100644 index 290170b..0000000 --- a/Com/Simatime/language/Bs/Eval.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Eval ( - evalText -, evalFile -, runParseTest -, safeExec -, runASTinEnv -, basicEnv -, fileToEvalForm -, textToEvalForm -, getFileContents -) where - -import Control.Exception -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.String -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Language.Bs.Expr -import Language.Bs.Parser -import Language.Bs.Primitives -import Protolude -import System.Directory - -funcEnv :: Map.Map T.Text Expr -funcEnv = Map.fromList $ primEnv - <> [ ("read" , IFun $ IFunc $ unop readFn) - , ("parse", IFun $ IFunc $ unop parseFn) - , ("eval", IFun $ IFunc $ unop eval) - , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) - ] - -basicEnv :: Env -basicEnv = Env Map.empty funcEnv - -readFn :: Expr -> Eval Expr -readFn (Tape txt) = lineToEvalForm txt -readFn val = throw $ TypeMismatch "read expects string, instead got:" val - -parseFn :: Expr -> Eval Expr -parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt -parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val - -safeExec :: IO a -> IO (Either String a) -safeExec m = do - result <- Control.Exception.try m - case result of - Left (eTop :: SomeException) -> - case fromException eTop of - Just (enclosed :: LispError) -> - return $ Left (show enclosed) - Nothing -> - return $ Left (show eTop) - Right val -> - return $ Right val - -runASTinEnv :: Env -> Eval b -> IO b -runASTinEnv code action = runReaderT (unEval action) code - -lineToEvalForm :: T.Text -> Eval Expr -lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input - -evalFile :: FilePath -> T.Text -> IO () -- program file -evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print - -fileToEvalForm :: FilePath -> T.Text -> Eval Expr -fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input - -runParseTest :: T.Text -> T.Text -- for view AST -runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input - -getFileContents :: FilePath -> IO T.Text -getFileContents fname = do - exists <- doesFileExist fname - if exists then TIO.readFile fname else return "File does not exist." - -textToEvalForm :: T.Text -> Eval Expr -textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input - -evalText :: T.Text -> IO () --REPL -evalText textExpr = do - res <- runASTinEnv basicEnv $ textToEvalForm textExpr - print res - -getVar :: Expr -> Eval Expr -getVar (Atom atom) = do - Env{..} <- ask - case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions - Just x -> return x - Nothing -> throw $ UnboundVar atom -getVar n = throw $ TypeMismatch "failure to get variable: " n - -ensureAtom :: Expr -> Eval Expr -ensureAtom n@(Atom _) = return n -ensureAtom n@(List _) = throw $ TypeMismatch "got list" n -ensureAtom n = throw $ TypeMismatch "expected an atomic value" n - -extractVar :: Expr -> T.Text -extractVar (Atom atom) = atom -extractVar n = throw $ TypeMismatch "expected an atomic value" n - -getEven :: [t] -> [t] -getEven [] = [] -getEven (x:xs) = x : getOdd xs - -getOdd :: [t] -> [t] -getOdd [] = [] -getOdd (_:xs) = getEven xs - -applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr -applyFunc expr params args = bindArgsEval params args expr - -bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr -bindArgsEval params args expr = do - Env{..} <- ask - let newVars = zipWith (\a b -> (extractVar a,b)) params args - let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars - local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr - -isFunc :: Expr -> Bool -isFunc (List ((Atom "lambda"):_)) = True -isFunc _ = False - -eval :: Expr -> Eval Expr -eval (List [Atom "dumpEnv", x]) = do - Env{..} <- ask - liftIO $ print $ toList env - liftIO $ print $ toList fenv - eval x - -eval (Numb i) = return $ Numb i -eval (Tape s) = return $ Tape s -eval (Bool b) = return $ Bool b -eval (List []) = return Nil -eval Nil = return Nil -eval n@(Atom _) = getVar n - -eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest -eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest - -eval (List [Atom "quote", val]) = return val - -eval (List [Atom "if", pred_, then_, else_]) = do - ifRes <- eval pred_ - case ifRes of - (Bool True) -> eval then_ - (Bool False) -> eval else_ - _ -> - throw $ BadSpecialForm "if's first arg must eval into a boolean" -eval (List ( (:) (Atom "if") _)) = - throw $ BadSpecialForm "(if )" - -eval (List [Atom "begin", rest]) = evalBody rest -eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest - --- top-level define --- TODO: how to make this eval correctly? -eval (List [Atom "define", List (name:args), body]) = do - Env{..} <- ask - _ <- eval body - bindArgsEval (name:args) [body] name - -eval (List [Atom "define", name, body]) = do - Env{..} <- ask - _ <- eval body - bindArgsEval [name] [body] name - -eval (List [Atom "let", List pairs, expr]) = do - Env{..} <- ask - atoms <- mapM ensureAtom $ getEven pairs - vals <- mapM eval $ getOdd pairs - bindArgsEval atoms vals expr - -eval (List (Atom "let":_) ) = - throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" - - -eval (List [Atom "lambda", List params, expr]) = do - ctx <- ask - return $ Func (IFunc $ applyFunc expr params) ctx -eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" - - --- needed to get cadr, etc to work -eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) = - return $ List xs -eval (List [Atom "cdr", arg@(List (x:xs))]) = - case x of - -- proxy for if the list can be evaluated - Atom _ -> do - val <- eval arg - eval $ List [Atom "cdr", val] - _ -> return $ List xs - - -eval (List [Atom "car", List [Atom "quote", List (x:_)]]) = - return $ x -eval (List [Atom "car", arg@(List (x:_))]) = - case x of - Atom _ -> do - val <- eval arg - eval $ List [Atom "car", val] - _ -> return $ x - - -eval (List ((:) x xs)) = do - Env{..} <- ask - funVar <- eval x - xVal <- mapM eval xs - case funVar of - (IFun (IFunc internalFn)) -> - internalFn xVal - - (Func (IFunc definedFn) (Env benv _)) -> - local (const $ Env benv fenv) $ definedFn xVal - - _ -> - throw $ NotFunction funVar - -updateEnv :: T.Text -> Expr -> Env -> Env -updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv -updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv -updateEnv var e Env{..} = Env (Map.insert var e env) fenv - -evalBody :: Expr -> Eval Expr -evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ eval rest - -evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do - evalVal <- eval defExpr - ctx <- ask - local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest - -evalBody x = eval x diff --git a/Com/Simatime/language/Bs/Expr.hs b/Com/Simatime/language/Bs/Expr.hs deleted file mode 100644 index a39c7b6..0000000 --- a/Com/Simatime/language/Bs/Expr.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Language.Bs.Expr where - -import Data.String (String) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Show -import Protolude hiding (show) -import qualified Text.PrettyPrint.Leijen.Text as PP -import Text.PrettyPrint.Leijen.Text hiding ((<$>)) - -type Ctx = Map Text Expr -data Env = Env { env :: Ctx, fenv :: Ctx } - deriving (Eq) - -newtype Eval a = Eval { unEval :: ReaderT Env IO a } - deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO) - -data IFunc = IFunc { fn :: [Expr] -> Eval Expr } - deriving (Typeable) - -instance Eq IFunc where - (==) _ _ = False - -data Expr - = Atom Text - | List [Expr] - | Numb Integer - | Tape Text - | IFun IFunc -- TODO: call this Kern - | Func IFunc Env - | Bool Bool - | Nil - deriving (Typeable, Eq) - -instance Show Expr where - show = T.unpack . ppexpr - -data LispErrorType - = NumArgs Integer [Expr] - | LengthOfList Text Int - | ExpectedList Text - | ParseError String - | TypeMismatch Text Expr - | BadSpecialForm Text - | NotFunction Expr - | UnboundVar Text - | Default Expr - | ReadFileError Text - deriving (Typeable) - -data LispError = LispError Expr LispErrorType - -instance Show LispErrorType where - show = T.unpack . ppexpr - -instance Show LispError where - show = T.unpack . ppexpr - -instance Exception LispErrorType -instance Exception LispError - -ppexpr :: Pretty a => a -> Text -ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x)) - ---prettyList :: [Doc] -> Doc ---prettyList = encloseSep lparen rparen PP.space - -instance Pretty Expr where - pretty v = - case v of - Atom a -> - textStrict a - - List ls -> - prettyList $ fmap pretty ls - - Numb n -> - integer n - - Tape t -> - textStrict "\"" <> textStrict t <> textStrict "\"" - - IFun _ -> - textStrict "" - - Func _ _ -> - textStrict "" - - Bool True -> - textStrict "#t" - - Bool False -> - textStrict "#f" - - Nil -> - textStrict "'()" - -instance Pretty LispErrorType where - pretty err = case err of - NumArgs i args -> - textStrict "number of arguments" - <$$> textStrict "expected" - <+> textStrict (T.pack $ show i) - <$$> textStrict "received" - <+> textStrict (T.pack $ show $ length args) - - - LengthOfList txt i -> - textStrict "length of list in:" - <+> textStrict txt - <$$> textStrict "length:" - <+> textStrict (T.pack $ show i) - - ParseError txt -> - textStrict "cannot parse expr:" - <+> textStrict (T.pack txt) - - TypeMismatch txt expr -> - textStrict "type mismatch:" - <$$> textStrict txt - <$$> pretty expr - - BadSpecialForm txt -> - textStrict "bad special form:" - <$$> textStrict txt - - NotFunction expr -> - textStrict "not a function" - <$$> pretty expr - - UnboundVar txt -> - textStrict "unbound variable:" - <$$> textStrict txt - - Default _ -> - textStrict "default error" - - ReadFileError txt -> - textStrict "error reading file:" - <$$> textStrict txt - - ExpectedList txt -> - textStrict "expected list:" - <$$> textStrict txt - -instance Pretty LispError where - pretty (LispError expr typ) = - textStrict "error evaluating:" - <$$> indent 4 (pretty expr) - <$$> pretty typ diff --git a/Com/Simatime/language/Bs/Parser.hs b/Com/Simatime/language/Bs/Parser.hs deleted file mode 100644 index 3044a60..0000000 --- a/Com/Simatime/language/Bs/Parser.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Parser ( - readExpr -, readExprFile -) where - -import Control.Monad (fail) -import Control.Monad (mzero) -import Data.Char (digitToInt) -import Data.Functor.Identity (Identity) -import Data.String -import qualified Data.Text as T -import Language.Bs.Expr -import Protolude hiding ((<|>), try) -import Text.Parsec -import qualified Text.Parsec.Language as Lang -import Text.Parsec.Text -import qualified Text.Parsec.Token as Tok - -lexer :: Tok.GenTokenParser T.Text () Identity -lexer = Tok.makeTokenParser style - -style :: Tok.GenLanguageDef T.Text () Identity -style = Lang.emptyDef { - Tok.commentStart = "#|" - , Tok.commentEnd = "|#" - , Tok.commentLine = ";" - , Tok.opStart = mzero - , Tok.opLetter = mzero - , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~" - , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@" - } - -parens :: Parser a -> Parser a -parens = Tok.parens lexer - -whitespace :: Parser () -whitespace = Tok.whiteSpace lexer - -lexeme :: Parser a -> Parser a -lexeme = Tok.lexeme lexer - -quoted :: Parser a -> Parser a -quoted p = try (char '\'') *> p - -identifier :: Parser T.Text -identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) "identifier" - where - specialIdentifier :: Parser String - specialIdentifier = lexeme $ try $ - string "-" <|> string "+" <|> string "..." - --- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for --- digits in that base (e.g. @digit@). -type Radix = (Integer, Parser Char) - --- | Parse an integer, given a radix as output by @radix@. --- Copied from Text.Parsec.Token -numberWithRadix :: Radix -> Parser Integer -numberWithRadix (base, baseDigit) = do - digits <- many1 baseDigit - let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits - seq n (return n) - -decimal :: Parser Integer -decimal = Tok.decimal lexer - --- | Parse a sign, return either @id@ or @negate@ based on the sign parsed. --- Copied from Text.Parsec.Token -sign :: Parser (Integer -> Integer) -sign = char '-' *> return negate - <|> char '+' *> return identity - <|> return identity - -intRadix :: Radix -> Parser Integer -intRadix r = sign <*> numberWithRadix r - -textLiteral :: Parser T.Text -textLiteral = T.pack <$> Tok.stringLiteral lexer - -nil :: Parser () -nil = try ((char '\'') *> string "()") *> return () "nil" - -hashVal :: Parser Expr -hashVal = lexeme $ char '#' - *> (char 't' *> return (Bool True) - <|> char 'f' *> return (Bool False) - <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01")) - <|> char 'o' *> (Numb <$> intRadix (8, octDigit)) - <|> char 'd' *> (Numb <$> intRadix (10, digit)) - <|> char 'x' *> (Numb <$> intRadix (16, hexDigit)) - <|> oneOf "ei" *> fail "Unsupported: exactness" - <|> char '(' *> fail "Unsupported: vector" - <|> char '\\' *> fail "Unsupported: char") - - -lispVal :: Parser Expr -lispVal = hashVal - <|> Nil <$ nil - <|> Numb <$> try (sign <*> decimal) - <|> Atom <$> identifier - <|> Tape <$> textLiteral - <|> _Quote <$> quoted lispVal - <|> List <$> parens manyExpr - -manyExpr :: Parser [Expr] -manyExpr = lispVal `sepBy` whitespace - -_Quote :: Expr -> Expr -_Quote x = List [Atom "quote", x] - -contents :: Parser a -> ParsecT T.Text () Identity a -contents p = whitespace *> lexeme p <* eof - -readExpr :: T.Text -> Either ParseError Expr -readExpr = parse (contents lispVal) "" - -readExprFile :: SourceName -> T.Text -> Either ParseError Expr -readExprFile = parse (contents (List <$> manyExpr)) diff --git a/Com/Simatime/language/Bs/Primitives.hs b/Com/Simatime/language/Bs/Primitives.hs deleted file mode 100644 index c074c59..0000000 --- a/Com/Simatime/language/Bs/Primitives.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | bs primitives --- --- I would like to reduce the number of primitives in the language to some --- minimal number, like SKI combinator or Nock instructions. I'm not sure what --- the minimal number is. The idea is to move primitives from here into core.scm --- over time. -module Language.Bs.Primitives where - -import Control.Exception -import Control.Monad.Except -import Data.Text as T -import Data.Text.IO as TIO -import Language.Bs.Expr -import Network.HTTP -import Protolude -import System.Directory -import System.IO - -type Prim = [(T.Text, Expr)] -type Unary = Expr -> Eval Expr -type Binary = Expr -> Expr -> Eval Expr - -mkF :: ([Expr] -> Eval Expr) -> Expr -mkF = IFun . IFunc - -primEnv :: Prim -primEnv = [ - ("+" , mkF $ binopFold (numOp (+)) (Numb 0) ) - , ("*" , mkF $ binopFold (numOp (*)) (Numb 1) ) - , ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") ) - , ("-" , mkF $ binop $ numOp (-)) - , ("<" , mkF $ binop $ numCmp (<)) - , ("<=" , mkF $ binop $ numCmp (<=)) - , (">" , mkF $ binop $ numCmp (>)) - , (">=" , mkF $ binop $ numCmp (>=)) - , ("==" , mkF $ binop $ numCmp (==)) - , ("even?" , mkF $ unop $ numBool even) - , ("odd?" , mkF $ unop $ numBool odd) - , ("neg?" , mkF $ unop $ numBool (< 0)) - , ("pos?" , mkF $ unop $ numBool (> 0)) - , ("eq?" , mkF $ binop eqCmd ) - , ("null?" , mkF $ unop (eqCmd Nil) ) - , ("bl-eq?" , mkF $ binop $ eqOp (==)) - , ("and" , mkF $ binopFold (eqOp (&&)) (Bool True)) - , ("or" , mkF $ binopFold (eqOp (||)) (Bool False)) - , ("not" , mkF $ unop $ notOp) - , ("cons" , mkF $ Language.Bs.Primitives.cons) - , ("cdr" , mkF $ Language.Bs.Primitives.cdr) - , ("car" , mkF $ Language.Bs.Primitives.car) - , ("quote" , mkF $ quote) - , ("file?" , mkF $ unop fileExists) - , ("slurp" , mkF $ unop slurp) - , ("wslurp" , mkF $ unop wSlurp) - , ("put" , mkF $ binop put_) - ] - -unop :: Unary -> [Expr] -> Eval Expr -unop op [x] = op x -unop _ args = throw $ NumArgs 1 args - -binop :: Binary -> [Expr] -> Eval Expr -binop op [x,y] = op x y -binop _ args = throw $ NumArgs 2 args - -fileExists :: Expr -> Eval Expr -fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt) -fileExists val = throw $ TypeMismatch "read expects string, instead got: " val - -slurp :: Expr -> Eval Expr -slurp (Tape txt) = liftIO $ wFileSlurp txt -slurp val = throw $ TypeMismatch "read expects string, instead got: " val - -wFileSlurp :: T.Text -> IO Expr -wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go - where go = readTextFile fileName - -openURL :: T.Text -> IO Expr -openURL x = do - req <- simpleHTTP (getRequest $ T.unpack x) - body <- getResponseBody req - return $ Tape $ T.pack body - -wSlurp :: Expr -> Eval Expr -wSlurp (Tape txt) = liftIO $ openURL txt -wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val - -readTextFile :: T.Text -> Handle -> IO Expr -readTextFile fileName h = do - exists <- doesFileExist $ T.unpack fileName - if exists - then (TIO.hGetContents h) >>= (return . Tape) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -put_ :: Expr -> Expr -> Eval Expr -put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg -put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val -put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val - -wFilePut :: T.Text -> T.Text -> IO Expr -wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go - where go = putTextFile fileName msg - -putTextFile :: T.Text -> T.Text -> Handle -> IO Expr -putTextFile fileName msg h = do - canWrite <- hIsWritable h - if canWrite - then (TIO.hPutStr h msg) >> (return $ Tape msg) - else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName] - -binopFold :: Binary -> Expr -> [Expr] -> Eval Expr -binopFold op farg args = case args of - []-> throw $ NumArgs 2 args - [a,b] -> op a b - _ -> foldM op farg args - -numBool :: (Integer -> Bool) -> Expr -> Eval Expr -numBool op (Numb x) = return $ Bool $ op x -numBool _ x = throw $ TypeMismatch "numeric op " x - -numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr -numOp op (Numb x) (Numb y) = return $ Numb $ op x y -numOp _ Nil (Numb y) = return $ Numb y -numOp _ (Numb x) Nil = return $ Numb x -numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numOp _ x _ = throw $ TypeMismatch "numeric op" x - -strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr -strOp op (Tape x) (Tape y) = return $ Tape $ op x y -strOp _ Nil (Tape y) = return $ Tape y -strOp _ (Tape x) Nil = return $ Tape x -strOp _ x (Tape _) = throw $ TypeMismatch "string op" x -strOp _ (Tape _) y = throw $ TypeMismatch "string op" y -strOp _ x _ = throw $ TypeMismatch "string op" x - -eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr -eqOp op (Bool x) (Bool y) = return $ Bool $ op x y -eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x -eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y -eqOp _ x _ = throw $ TypeMismatch "bool op" x - -numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr -numCmp op (Numb x) (Numb y) = return . Bool $ op x y -numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x -numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y -numCmp _ x _ = throw $ TypeMismatch "numeric op" x - -notOp :: Expr -> Eval Expr -notOp (Bool True) = return $ Bool False -notOp (Bool False) = return $ Bool True -notOp x = throw $ TypeMismatch " not expects Bool" x - -eqCmd :: Expr -> Expr -> Eval Expr -eqCmd (Atom x) (Atom y) = return . Bool $ x == y -eqCmd (Numb x) (Numb y) = return . Bool $ x == y -eqCmd (Tape x) (Tape y) = return . Bool $ x == y -eqCmd (Bool x) (Bool y) = return . Bool $ x == y -eqCmd Nil Nil = return $ Bool True -eqCmd _ _ = return $ Bool False - -cons :: [Expr] -> Eval Expr -cons [x,(List ys)] = return $ List $ x:ys -cons [x,y] = return $ List [x,y] -cons _ = throw $ ExpectedList "cons, in second argument" - -car :: [Expr] -> Eval Expr -car [List [] ] = return Nil -car [List (x:_)] = return x -car [] = return Nil -car _ = throw $ ExpectedList "car" - -cdr :: [Expr] -> Eval Expr -cdr [List (_:xs)] = return $ List xs -cdr [List []] = return Nil -cdr [] = return Nil -cdr _ = throw $ ExpectedList "cdr" - -quote :: [Expr] -> Eval Expr -quote [List xs] = return $ List $ Atom "quote" : xs -quote [expr] = return $ List $ Atom "quote" : [expr] -quote args = throw $ NumArgs 1 args diff --git a/Com/Simatime/language/Bs/Repl.hs b/Com/Simatime/language/Bs/Repl.hs deleted file mode 100644 index 64ffaa2..0000000 --- a/Com/Simatime/language/Bs/Repl.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Repl ( -mainLoop -) where - -import Control.Monad.Trans -import Data.String -import Data.Text as T -import Language.Bs.Eval -import Protolude -import System.Console.Haskeline - -type Repl a = InputT IO a - -mainLoop :: IO () -mainLoop = runInputT defaultSettings repl - -repl :: Repl () -repl = do - minput <- getInputLine "bs> " - case minput of - Nothing -> outputStrLn "bye." - Just input -> (liftIO $ process input) >> repl - --Just input -> (liftIO $ processToAST input) >> repl - -process :: String -> IO () -process str = do - res <- safeExec $ evalText $ T.pack str - either putStrLn return res - -processToAST :: String -> IO () -processToAST str = print $ runParseTest $ T.pack str diff --git a/Com/Simatime/language/Bs/Test.hs b/Com/Simatime/language/Bs/Test.hs deleted file mode 100644 index 4a40036..0000000 --- a/Com/Simatime/language/Bs/Test.hs +++ /dev/null @@ -1,2 +0,0 @@ --- TODO -module Language.Bs.Test where diff --git a/Com/Simatime/repl.scm b/Com/Simatime/repl.scm deleted file mode 100644 index 4913383..0000000 --- a/Com/Simatime/repl.scm +++ /dev/null @@ -1,23 +0,0 @@ -(define-module (Com Simatime repl) - #:export ()) - - -;; -;; repl customization -;; - -;; (use-modules (system repl common)) -;; (repl-default-option-set! -;; 'prompt -;; (lambda (repl) -;; (format #f "\n[~a@~a:~a]\nλ> " -;; (getenv "USER") -;; (vector-ref (uname) 1) -;; (pwd)))) - -;; TODO(bsima): (doc x) -;; TODO(bsima): (src x) -;; TODO(bsima): ,src command -;; TODO(bsima): ,shell command -;; TODO(bsima): how to load this file on startup? -;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl diff --git a/Com/Simatime/shell.scm b/Com/Simatime/shell.scm deleted file mode 100644 index 02c4e00..0000000 --- a/Com/Simatime/shell.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (Com Simatime shell) - #:use-module ((ice-9 popen) #:prefix popen/) - #:use-module ((ice-9 rdelim) #:prefix rdelim/) - #:use-module ((ice-9 ftw) #:prefix ftw/) - #:export (exec - stream - pwd - ls - cd)) - -(define (exec cmd) - (let* ((port (popen/open-input-pipe cmd)) - (ret (read port))) - (popen/close-pipe port) - ret)) - -(define (stream cmd) - (let* ((port (popen/open-input-pipe cmd)) - (_ (setvbuf port 'none)) - (ret (rdelim/read-string port))) - (flush-all-ports) - (popen/close-pipe port) - ret)) - -(define (pwd) - (regexp-substitute/global - #f "/home/ben" (getcwd) 'pre "~" 'post)) - -(define (ls) - (ftw/scandir (getcwd))) - -(define (cd path) - (chdir path) - (ls)) diff --git a/Com/Simatime/string.scm b/Com/Simatime/string.scm deleted file mode 100644 index 3d32cd1..0000000 --- a/Com/Simatime/string.scm +++ /dev/null @@ -1,24 +0,0 @@ -(define-module (Com Simatime string) - #:export (replace to-string str capitalize)) - -(define (replace s match repl) - (let ((f (lambda (a b) - (let ((next-char (if (eq? a match) repl a))) - (string-concatenate (list b (string next-char))))))) - (string-fold f "" s))) - -(define (to-string x) - (format #f "~a" x)) - -(define str - (case-lambda - (() "") - ((x) (to-string x)) - ((x . rest) (string-concatenate (map str (cons x rest)))))) - -(define (capitalize s) - (let ((s (to-string s))) - (if (< (string-length s) 2) - (string-upcase s) - (str (string-upcase (substring s 0 1)) - (substring s 1 ))))) -- cgit v1.2.3