octopus 0.0.1.0 → 0.0.2.0
raw patch · 17 files changed
+1274/−1041 lines, 17 filesdep ~hexprnew-component:exe:octi
Dependency ranges changed: hexpr
Files
- Language/Octopus.hs +240/−0
- Language/Octopus/Basis.hs +107/−0
- Language/Octopus/Data.hs +152/−0
- Language/Octopus/Data/Shortcut.hs +34/−0
- Language/Octopus/Libraries.hs +37/−0
- Language/Octopus/Parser.hs +339/−0
- Language/Octopus/Parser/Preprocess.hs +18/−0
- Language/Octopus/Primitive.hs +279/−0
- Octopus.hs +0/−175
- Octopus/Basis.hs +0/−98
- Octopus/Data.hs +0/−132
- Octopus/Libraries.hs +0/−94
- Octopus/Parser.hs +0/−211
- Octopus/Primitive.hs +0/−214
- Octopus/Shortcut.hs +0/−25
- main.hs +55/−80
- octopus.cabal +13/−12
+ Language/Octopus.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Octopus where++import Import+import qualified Data.Sequence as Seq+import qualified Data.Map as Map++import Control.Monad.State+import Control.Monad.Reader+import System.IO.Error+import Control.Concurrent.MVar++import Language.Octopus.Data+import Language.Octopus.Parser (parseOctopusFile)+import qualified Language.Octopus.Primitive as Oct+import Language.Octopus.Basis+import Language.Octopus.Data.Shortcut+import Language.Octopus.Libraries+++eval :: ImportsCache -> Val -> Val -> IO Val+eval cache env code = evalStateT (runReaderT (reduce code) cache) startState+ where+ startState = MState { environ = env --Ob Map.empty+ , control = [NormK []]+ , nextTag = startTag+ }+++reduce :: Val -> Machine Val+reduce x@(Nm _) = done x+reduce x@(By _) = done x+reduce x@(Tx _) = done x+reduce x@(Fp _) = done x+reduce x@(Tg _ _) = done x+reduce x@(Ab _ _) = done x+reduce x@(Cl _ _ _) = done x+reduce x@(Ce _) = done x+reduce x@(Ar _) = done x+--reduce x@(Eh _ _) = done x+--reduce x@(Ex _ _) = done x+reduce x@(Pr _) = done x+reduce sq@(Sq xs) = case toList xs of+ [] -> done sq+ (x:xs) -> push (Es [] xs) >> reduce x+reduce ob@(Ob m) = case ensureCombination ob of+ Just (f, x) -> push (Op x) >> reduce f+ Nothing -> case Map.toList m of+ [] -> done (mkOb [])+ ((k,v):xs) -> push (Eo k [] xs) >> reduce v+reduce (Sy x) = gets environ >>= \env -> case Oct.resolveSymbol x env of+ Just val -> done val+ Nothing -> do+ env <- gets environ+ raise (getTag exnScopeError, mkSq [exnScopeError, Sy x, env])++combine :: Val -> Val -> Machine Val+combine (Pr Vau) x = case x of+ Sq xs -> case toList xs of+ [var, ast] -> do+ env <- gets environ+ done $ Cl var ast env+ _ -> raise $ mkTypeError (Pr Vau) "(Pat, *)" x+ _ -> raise $ mkTypeError (Pr Vau) "(Pat, *)" x+combine f@(Pr _) x = push (Ap f) >> reduce x+combine f x = case ensureClosure f of --all of these are operatives+ Just (var, ast, env) -> do+ caller <- gets environ+ let x' = mkSq [caller, x]+ case Oct.match var x' of+ Right env' -> swapEnv (env' `Oct.extend` env) >> reduce ast+ Left err -> raise err+ _ -> raise $ mkTypeError (Tx "#<apply>") "* → *" f++apply :: Val -> Val -> Machine Val+apply (Pr Eval) x = case ensureThunk x of+ Just (env, ast) -> swapEnv env >> reduce ast+ _ -> raise $ mkTypeError (Pr Eval) "Thunk *" x+apply (Pr Ifz) x = case x of+ Sq xs -> case toList xs of+ [p, c, a] -> done $ Oct.ifz p c a+ _ -> tyErr+ _ -> tyErr+ where tyErr = raise $ mkTypeError (Pr Ifz) "(*, *, *)" x+apply (Pr Imp) x = impFile x+apply (Pr Extends) x = case x of+ Sq xs -> case toList xs of+ [] -> done $ mkOb []+ xs -> done $ foldr1 Oct.extend xs+ _ -> raise $ mkTypeError (Pr Extends) "[*]" x+apply (Pr MkTag) x = case x of+ Tx spelling -> done =<< mkTag spelling+ _ -> raise $ mkTypeError (Pr MkTag) "Tx" x+apply (Pr Handle) x = case x of+ Sq xs -> case toList xs of+ [tag, handler, body] -> case tag of+ Tg i _ -> pushK (HndlK i handler) >> reduce body+ _ -> tyErr+ _ -> tyErr+ _ -> tyErr+ where tyErr = raise $ mkTypeError (Pr Handle) "∀ r. (Tg, * → r, `r)" x --FIXME give the type as a monad+apply (Pr Raise) x = case x of+ Sq xs -> case toList xs of+ [tag, payload] -> case tag of+ Tg i _ -> curry raise i payload+ _ -> tyErr+ _ -> tyErr+ _ -> tyErr+ where tyErr = raise $ mkTypeError (Pr Raise) "(Tg, *)" x+apply (Pr pr) x | pr `elem` (map fst table) = do+ result <- liftIO $ (fromJust $ lookup pr table) x+ case result of+ Right val -> done val+ Left err -> raise err+ where+ table =+ [ (OpenFp, Oct.openFp)+ , (ReadFp, Oct.readFp)+ , (WriteFp, Oct.writeFp)+ , (FlushFp, Oct.flushFp)+ , (CloseFp, Oct.closeFp)+ ]+apply (Pr pr) x =+ case lookup pr table of+ Just f -> case f pr x of+ Right val -> done val+ Left err -> raise err+ Nothing -> error $ "INTERNAL ERROR (Octopus.apply): unknown primitive " ++ show pr+ where+ table = + [ (Match, binary Oct.match "TODO")+ + , (Delete, binary Oct.delete "TODO")+ , (Keys, unary Oct.keys)+ , (Get, binary Oct.get "TODO")+ + , (Eq, binary Oct.eq "(*, *)")+ , (Neq, binary Oct.neq "(*, *)")+ , (Lt, binary Oct.lt "(Nm, Nm)")+ , (Lte, binary Oct.lte "(Nm, Nm)")+ , (Gt, binary Oct.gt "(Nm, Nm)")+ , (Gt, binary Oct.gt "(Nm, Nm)")+ + , (Add, binary Oct.add "(Nm, Nm)")+ , (Sub, binary Oct.sub "(Nm, Nm)")+ , (Mul, binary Oct.mul "(Nm, Nm)")+ , (Div, binary Oct.div "(Nm, Nm)")+ + , (Len, unary Oct.len)+ , (Cat, binary Oct.cat "∀ f :: Sq * | Tx | By. (f, f)")+ , (Cut, binary Oct.cut "(Sq * | Tx | By, Nat)")+ + , (Numer, unary Oct.numer)+ , (Denom, unary Oct.denom)+ , (NumParts, unary Oct.numParts)+ ]+ binary :: (Val -> Val -> Fallible Val) -> Text -> Primitive -> Val -> Fallible Val+ binary op ty pr x = case x of+ Sq xs -> case toList xs of+ [a, b] -> op a b+ _ -> tyErr+ _ -> tyErr+ where tyErr = Left $ mkTypeError (Pr pr) ty x+ unary :: (Val -> Fallible Val) -> Primitive -> Val -> Fallible Val+ unary op pr x = op x+--TODO Ks+--TODO apply objects that have a __call__ field, passing the object as the first parameter+--TODO unwrap Ab and try the __call__ protocol trick+apply f x = error "TODO apply"++done :: Val -> Machine Val+done x = do+ k <- gets control+ case k of+ [] -> return x+ (NormK []):_ -> pop >> done x+ (NormK (Re _:_)):_ -> pop >> done x+ (NormK (Es xs []:_)):_ -> pop >> done (Sq . Seq.fromList $ reverse (x:xs))+ (NormK (Es xs (x':xs'):_)):_ -> replace (Es (x:xs) xs') >> reduce x'+ (NormK (Eo k xs []:_)):_ -> pop >> done (Ob . Map.fromList $ (k,x):xs)+ (NormK (Eo k xs ((k',x'):xs'):_)):_ -> replace (Eo k' ((k,x):xs) xs') >> reduce x'+ (NormK (Op arg:ks)):kss -> pop >> combine x arg+ (NormK (Ap f:ks)):kss -> pop >> apply f x+ (HndlK _ _):kss -> pop >> done x+ (ImptK _ slot):kss -> liftIO (slot `putMVar` Right x) >> pop >> done x+++raise :: Exn -> Machine Val+raise (tg, payload) = do+ (top, rest) <- splitStack tg+ case rest of+ [] -> error $ "unhandled exception: " ++ show (tg, payload) --return here+ (ImptK file slot):kss -> do+ let err = (getTag exnImportError, mkSq [exnImportError, Tx file, payload])+ liftIO $ slot `putMVar` Left err+ modify $ \s -> s { control = kss }+ raise err+ (HndlK _ handler):kss -> do+ modify $ \s -> s { control = kss }+ reduce $ mkCall handler payload+++impFile :: Val -> Machine Val+impFile (Tx pathstr) = do+ let path = pathstr --FIXME normalize path+ path' = unpack path+ --TODO check against builtin files, or else pre-populate the cache+ --TODO check the path against the current imports on stack to avoid circular import+ cache_var <- ask+ cache <- liftIO $ takeMVar cache_var+ case Map.lookup path cache of+ Just loaded_var -> do+ liftIO $ cache_var `putMVar` cache+ val_e <- liftIO $ readMVar loaded_var+ case val_e of+ Right val -> done val+ Left err -> raise err+ Nothing -> do+ loading_var <- liftIO newEmptyMVar+ liftIO $ cache_var `putMVar` Map.insert path loading_var cache+ contents_e <- liftIO $ tryIOError $ readFile path'+ case contents_e of+ Right contents -> do+ case parseOctopusFile path' contents of+ Right (_, val) -> do+ swapEnv initialEnv --TODO consider which env to start a file off with+ pushK (ImptK path loading_var)+ reduce val+ Left raw_err -> do+ let err = (getTag exnSyntaxError, mkSq [exnSyntaxError, Tx . pack $ show raw_err])+ liftIO $ loading_var `putMVar` Left err+ raise err+ Left raw_err -> do+ --TODO format the IOError the way I want it, not the way Haskell gives it+ let err = (getTag exnIOError, mkSq [exnIOError, Tx . pack $ show raw_err])+ liftIO $ loading_var `putMVar` Left err+ raise err+impFile x = raise $ mkTypeError (Pr Imp) "Tx" x++
+ Language/Octopus/Basis.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-| This module contains values that help create and manipulate Octopus+ values that are used by the interpreter, but not strictly primitive,+ that is, they could just as easily be defined in user-space, as long+ as the machine could get at them.+-}+module Language.Octopus.Basis where++import Import+import qualified Data.Sequence as Seq+import qualified Data.Map as Map+import System.IO++import Language.Octopus.Data+import Language.Octopus.Data.Shortcut+++fpStdin = Fp stdin+fpStdout = Fp stdout+fpStderr = Fp stderr++exnTypeError = Tg 0 "TypeError"+exnMatchFail = Tg 1 "MatchFailure"+exnScopeError = Tg 2 "ScopeError"+exnAttrError = Tg 3 "AttributeError"+exnIndexError = Tg 4 "IndexError"+exnDivZero = Tg 5 "DivideByZero"+exnIOError = Tg 6 "IOError"+exnSyntaxError = Tg 7 "SyntaxError"+exnImportError = Tg 8 "ImportError"+startTag :: Word+startTag = 9++++mkTypeError :: Val -> Text -> Val -> (Word, Val)+mkTypeError f ty val = (getTag exnTypeError, mkSq [exnTypeError, f, Tx ty, val])+mkMatchFail :: Val -> Val -> (Word, Val)+mkMatchFail p v = (getTag exnMatchFail, mkSq [exnMatchFail, p, v])+++mkVau :: String -> String -> Val -> Val+mkVau e arg body = mkCall (Pr Vau) (mkSq [mkSq [Sy $ intern e, Sy $ intern arg], body])++{-| Construct a combination: an object with a+ @__car__@ slot and a @__cdr__@ slot.+-}+mkCall :: Val -- ^ Combiner (@__car__@)+ -> Val -- ^ Argument (@__cdr__@)+ -> Val+mkCall f x = mkOb [(callOpr, f), (callArg, x)]++{-| Extract a (combiner, argument) pair from a+ combination-responsive object.+-}+ensureCombination :: Val -> Maybe (Val, Val)+ensureCombination (Ob ob) = (,) <$> Map.lookup callOpr ob+ <*> Map.lookup callArg ob+ensureCombination _ = Nothing++{-| Combiner slot name in a combination (aka. application) -}+callOpr :: Symbol+callOpr = intern "__car__"+{-| Argument slot name in a combination (aka. application) -}+callArg :: Symbol+callArg = intern "__cdr__"+++{-| Construct a closure: an object with @__var__@,+ @__ast__@ and @__env__@ slots.+-}+mkClosure :: Val -- ^ Body (@__ast__@)+ -> Val -- ^ Static environment (@__env__@)+ -> Val -- ^ Parameter (@__arg__@)+ -> Val+mkClosure var ast env = Cl var ast env++{-| Extract a (body, environment, parameter) triple from+ a closure-responsive object.+-}+ensureClosure :: Val -> Maybe (Val, Val, Val)+ensureClosure (Cl var ast env) = Just (var, ast, env)+ensureClosure _ = Nothing+++{-| Construct a thunk: a (environment, body) pair. -}+mkThunk :: Val -- ^ Environment (second element)+ -> Val -- ^ Body (first element)+ -> Val+mkThunk env ast = Sq $ Seq.fromList [env, ast]++{-| Extract a (environment, body) pair from a thunk-responsive pair. -}+ensureThunk :: Val -> Maybe (Val, Val)+ensureThunk (Sq xs) = case toList xs of+ [env, ast] -> Just (env, ast)+ _ -> Nothing+ensureThunk _ = Nothing++++++++++
+ Language/Octopus/Data.hs view
@@ -0,0 +1,152 @@+module Language.Octopus.Data where++import Import+import qualified Data.Sequence as Seq+import qualified Data.Map as Map+import Control.Monad.Reader+import Control.Monad.State+import Control.Concurrent.MVar (MVar)+++type Exn = (Word, Val)+type Fallible = Either Exn+++data Val = Nm Rational -- ^ Rational number+ | By ByteString -- ^ Bytes+ | Tx Text -- ^ Text data+ | Fp Handle -- ^ Input/output handle+ | Sy Symbol -- ^ Symbol, aka. identifier+ | Tg Word Text -- ^ Unique tag+ | Ab Word Val -- ^ Abstract data+ | Sq (Seq Val) -- ^ Sequence, aka. list+ | Ob (Map Symbol Val) -- ^ Symbol-value map, aka. object+ | Cl Val Val Val -- ^ Operative closure+ | Ce (IORef Val) -- ^ Reference cell+ | Ar (IOArray Int Val) -- ^ Mutable array+ | Pr Primitive -- ^ Primitive operations+ -- | Eh Val Val -- ^ Exception handler/control prompt+ -- | Ex Val Val -- ^ Propagating exception+ | Ks [Control] -- ^ Control stack + --TODO bytestring/buffer/bytes/other name?+ --TODO concurrency+ deriving (Eq)+data Primitive = Vau | Eval | Match | Ifz | Imp+ | Eq | Neq | Lt | Lte | Gt | Gte+ | Add | Mul | Sub | Div+ | Numer | Denom | NumParts+ --TODO By data primitives+ --TODO Tx data primitives+ --TODO Fp data primitives+ | OpenFp | ReadFp | WriteFp | FlushFp | CloseFp+ --TODO Sy data primitives+ | MkTag+ | Wrap Word | Unwrap Word+ | Len | Cat | Cut+ | Extends | Delete | Keys | Get+ --TODO Ce data primitives+ --TODO Ar data primitives+ --TODO Pt/Ks data primitives+ | Handle | Raise+ deriving (Eq, Show)++++type FileCache = MVar (Fallible Val)+type ImportsCache = MVar (Map Text FileCache)+data MState = MState { environ :: Val+ , control :: [Control]+ , nextTag :: Word+ }++type Machine = ReaderT ImportsCache (StateT MState IO)+++data Context = Op Val -- ^ Hole must be a combiner, val is the uneval'd argument+ | Ap Val -- ^ Hole is the argument, apply held value to it+ | Re Val -- ^ Restore an environment before continuing+ | Es [Val] [Val] -- ^ Left-to-right sequence evaluation+ | Eo Symbol [(Symbol, Val)] [(Symbol, Val)] -- ^ Object evaluation+ deriving (Eq, Show)+data Control = NormK [Context]+ | HndlK Word Val+ --TODO onEnter/onSuccess/onFail+ | ImptK Text (MVar (Fallible Val))+ deriving (Eq)+instance Show Control where+ show (NormK k) = "NormK " ++ show k+ show (HndlK i fn) = "HndlK " ++ show i ++ " " ++ show fn+ show (ImptK path slot) = "ImptK " ++ show path+++push :: Context -> Machine ()+push k = do+ (NormK ks):kss <- gets control+ modify $ \s -> s { control = (NormK (k:ks)):kss }+ --FIXME remember that when I push a handler or a winding protect, I also need to push an environment restore+pushK :: Control -> Machine ()+pushK k@(NormK _) = do+ ks <- gets control+ modify $ \s -> s { control = k:ks }+pushK k = do+ ks <- gets control+ modify $ \s -> s { control = (NormK []):k:ks }+pop :: Machine ()+pop = do+ stack <- gets control+ case stack of+ (NormK []):kss -> modify $ \s -> s { control = kss }+ (NormK (Re env:ks)):kss -> modify $ \s -> s { environ = env, control = (NormK ks):kss }+ (NormK (_:ks)):kss -> modify $ \s -> s { control = (NormK ks):kss }+ (HndlK _ _):kss -> modify $ \s -> s { control = kss }+ (ImptK _ _):kss -> modify $ \s -> s { control = kss }+replace :: Context -> Machine ()+replace k = pop >> push k++swapEnv :: Val -> Machine ()+swapEnv env' = do+ env <- gets environ+ (NormK ks):kss <- gets control+ case ks of+ (Re _):_ -> modify $ \s -> s { environ = env' } --allows tail recursion by not restoring environments that will immediately be thrown away by a second restoration+ ks -> modify $ \s -> s { environ = env', control = (NormK ((Re env):ks)):kss }++splitStack :: Word -> Machine ([Control], [Control])+splitStack tg = break isPoint <$> gets control+ where+ isPoint (HndlK tg' _) = tg == tg'+ isPoint (ImptK _ _) = True+ isPoint _ = False++++mkTag :: Text -> Machine Val+mkTag spelling = do+ n <- gets nextTag+ modify $ \s -> s { nextTag = n + 1 }+ return $ Tg n spelling+++instance Show Val where+ show (Nm nm) | denominator nm == 1 = show $ numerator nm+ | otherwise = show (numerator nm) ++ "/" ++ show (denominator nm)+ show (By bytes) = "b" ++ show bytes --FIXME show with \x?? for non-ascii printable chars+ show (Tx text) = show text --FIXME show using Octopus encoding, not Haskell+ show (Fp _) = "#<handle>" --TODO at least show some metadata+ show (Sy sy) = show sy+ show (Tg i spelling) = "#<tag " ++ show i ++ ": " ++ show spelling ++ ">"+ show (Ab tag x) = "#<box " ++ show tag ++ ": " ++ show x ++ ">"+ show (Sq xs) = "[" ++ intercalate ", " (show <$> toList xs) ++ "]"+ show (Ob m) = case getCombo m of+ Nothing -> "{" ++ intercalate ", " (showPair <$> Map.toList m) ++ "}"+ Just (f, x) -> "(" ++ show f ++ " " ++ show x ++ ")"+ where+ showPair (k,v) = show k ++ ": " ++ show v+ getCombo ob = case (Map.lookup (intern "__car__") ob, Map.lookup (intern "__cdr__") ob) of+ (Just f, Just x) -> if length (Map.keys ob) == 2 then Just (f, x) else Nothing+ _ -> Nothing+ show (Cl var ast env) = "#<closure>"+ show (Ce x) = "<reference cell>" --TODO show contents+ show (Ar xs) = "#<mutable array>" --TODO show contents+ --show (Eh tag fn) = "#<handler " ++ show tag ++ ": " ++ show fn ++ ">"+ show (Pr f) = "#<" ++ show f ++ ">"
+ Language/Octopus/Data/Shortcut.hs view
@@ -0,0 +1,34 @@+module Language.Octopus.Data.Shortcut where++import Import+import qualified Data.Sequence as Seq+import qualified Data.Map as Map++import Language.Octopus.Data+++mkInt :: Integral a => a -> Val+mkInt = Nm . fromIntegral++mkSy :: String -> Val+mkSy = Sy . intern++mkTx :: String -> Val+mkTx = Tx . pack++mkBy :: String -> Val+mkBy = By . encodeUtf8 . pack++mkSq :: [Val] -> Val+mkSq = Sq . Seq.fromList++mkOb :: [(Symbol, Val)] -> Val+mkOb = Ob . Map.fromList+++getTag :: Val -> Word+getTag (Tg tg _) = tg++fromEnv :: Val -> Map Symbol Val+fromEnv (Ob ob) = ob+fromEnv _ = Map.empty
+ Language/Octopus/Libraries.hs view
@@ -0,0 +1,37 @@+module Language.Octopus.Libraries where++import Import+import Language.Octopus.Data+import Language.Octopus.Data.Shortcut+import Language.Octopus.Basis++initialEnv = mkOb [+ (intern "__let__", letDef)+ , (intern "__open__", openDef)+ --- Exceptions --- TODO give builtin literals+ , (intern "TypeError", exnTypeError)+ , (intern "MatchFailure", exnMatchFail)+ , (intern "DivZero", exnDivZero)+ ]++letDef = Cl+ (mkSq [mkOb [], mkSy "x"])+ (mkCall (Pr Vau) (mkSq [mkSy "val",+ mkCall (Pr Vau) (mkSq [mkSq [mkSy "e", mkSy "body"],+ mkCall (Pr Eval) (mkSq+ [ mkCall (Pr Extends) (mkSq + [ mkCall (Pr Match) (mkSq [mkSy "x", mkCall (Pr Eval) (mkSy "val")])+ , mkSy "e"])+ , mkSy "body"])])]))+ (mkOb [])+openDef = Cl+ (mkSy "env")+ (mkCall (Pr Vau) (mkSq [mkSq [mkSy "static", mkSy "body"],+ mkCall (Pr Eval) (mkSq + [ mkCall (Pr Extends) (mkSq+ [ mkCall (Pr Eval) (mkSy "env")+ , mkSy "static"])+ , mkSy "body"])]))+ (mkOb [])+ +
+ Language/Octopus/Parser.hs view
@@ -0,0 +1,339 @@+{-| Parse Octopus source code. The Octopus grammar is:+++> file ::= ('export' <expr>)? <stmt>*+> stmt ::= <expr> | _field_ <expr> | 'open' <expr>+> expr ::= <atom> | <list> | <object>+> | <combination> | <block> | <quotation>+> | <accessor> | <mutator>+> | '(' <expr> ')' | /\.<expr>/+> +> atom ::= _symbol_ | _number_ | _string_ | _heredoc_ | _primitive_+> list ::= '[' (<expr>+ (',' <expr>+)*)? ']'+> object ::= '{' (_field_ <expr>+ (',' _field_ <expr>+)*)? '}'+> combination ::= '(' <expr> <expr>+ ')'+> block ::= 'do' <stmt>+ ';'+> accessor ::= /@<name>/ | /:<name>/+> mutator ::= '@(' _field_ <expr>+ ')' | ':(' _field_ <expr>+ ')'+> quotation ::= /`<expr>/+> +> symbol ::= _name_ - reserved+> reserved = {'do', 'letrec', 'export', 'open'}+> primitive ::= /#<[a-zA-Z]+>/+> field ::= /<name>:/+> number ::= /[+-]?(0[xX]<hexnum>|0[oO]<octnum>|0[bB]<binnum>|<decnum>)/+> decnum ::= /\d+(\.\d+<exponent>?|\/\d+)?/+> hexnum ::= /\x+(\.\x+([hH][+-]?\x+)?|\/\x+)?/+> octnum ::= /[0-7]+(\.[0-7]+<exponent>?|\/[0-7]+)?/+> binnum ::= /[01]+(\.[01]+<exponent>?|\/[01]+)?/+> exponent ::= /[eE][+-]?\d+|[hH][+-]?\x+/+> string ::= /"([^"\\]|\\[abefntv'"&\\]|\\<numescape>|\\\s*\n\s*\\)*"/+> numescape ::= /[oO][0-7]{3}|[xX]\x{2}|u\x{4}|U0\x{5}|U10x{4}/+> heredoc ::= /#<<(?'END'\w+)\n.*?\n\g{END}>>(\n|$)/+> name ::= /<namehead><nametail>|-<namehead><nametail>|-(-<nametail>)?/+> namehead = /[^#\\"`()[]{}@:;.,0-9-]/+> nametail = /[^#\\"`()[]{}@:;.,]*/+> +> linecomment ::= /#(?!<)\.*?\n/+> blockcomment ::= /#\{([^#}]+|<blockcomment>|#[^{]|\}[^#])*\}#/++-}+module Language.Octopus.Parser where++import Import++import qualified Data.ByteString.Lazy as BS+import qualified Data.Text as T+import Text.Parsec ( Parsec, SourceName, ParseError+ , try, (<?>), unexpected+ , char, anyChar, oneOf, noneOf, eof)+import qualified Text.Parsec as P+import Language.Parse+import Language.Desugar++import Language.Octopus.Data+import Language.Octopus.Data.Shortcut+import Language.Octopus.Basis+import Language.Octopus.Parser.Preprocess+++type Parser = Parsec String ()+type Directive = String++parseOctopusExpr :: SourceName -> String -> Either ParseError Val+parseOctopusExpr sourceName input = desugar <$> P.runParser (padded expr <* padded eof) () sourceName input++parseOctopusFile :: SourceName -> String -> Either ParseError ([Directive], Val)+parseOctopusFile sourceName input =+ let (directives, code) = partitionCode input+ in (,) directives <$> P.runParser octopusFile () sourceName code+ where+ octopusFile = do+ es <- P.many $ desugarStatement <$> padded statement+ padded eof+ return $ loop es+ loop [] = mkCall getenv (mkOb [])+ loop (Defn s:rest) = mkCall (mkDefn s) (loop rest)+ loop (Open e:rest) = mkCall (mkOpen e) (loop rest)+ loop (Expr e:rest) = mkCall (mkExpr e) (loop rest)+ getenv = (mkCall (Pr Vau) (mkSq [mkSq [mkSy "e", mkOb []], mkSy "e"]))++define :: Parser (Defn Syx)+define = do+ var <- try (expr <* char ':' <* whitespace)+ body <- expr+ return (var, body)++letrec :: Parser (Defn Syx)+letrec = do+ try $ string "letrec" <* whitespace+ var <- try (expr <* char ':' <* whitespace)+ body <- expr+ return (var, body) ++open :: Parser Syx+open = do+ try $ string "open" *> whitespace+ expr++expr :: Parser Syx+expr = composite P.<|> atom+ where+ atom = Lit <$> P.choice [symbol, numberLit, textLit, heredoc, primitive] <?> "atom"+ composite = P.choice [ block, combine, sq, ob, quote, dottedExpr+ , accessor, mutator, infixAccessor, infixMutator]++statement :: Parser (Statement Syx)+statement = P.choice [ Defn <$> define+ , LRec <$> letrec+ , Open <$> open+ , Expr <$> expr+ ]+++------ Sugar ------+data Statement a = Defn (Defn a)+ | LRec (Defn a)+ | Expr a+ | Open a+ | Deco a+ deriving (Show)+type Defn a = (a, a)+data Syx = Lit Val+ | Call [Syx]+ | SqSyx [Syx]+ | ObExpr [(Symbol, Syx)]+ | Do [Statement Syx]+ | Infix Syx+ deriving (Show)++desugar :: Syx -> Val+desugar (Lit x) = x+desugar (Call [x]) = desugar x+desugar (Call xs) = loop . (desugar <$>) $ revTripBy isInfix (id, rewrite) xs+ where+ rewrite [] inf rest = error "TODO syntax error: infix :/. needs a subject"+ rewrite subject (Infix inf) rest = inf : Call subject : rest+ loop [e] = e+ loop [f, x] = mkCall f x+ loop es = mkCall (loop $ init es) (last es)+ isInfix (Infix _) = True+ isInfix _ = False+desugar (SqSyx xs) = mkSq $ desugar <$> xs+desugar (ObExpr xs) = mkOb $ desugarField <$> xs+desugar (Do xs) = loop xs+ where+ loop [Defn d] = mkCall (mkDefn $ desugarDefine d) (mkOb [])+ loop [Expr e] = desugar e+ loop (Defn d:rest) = mkCall (mkDefn $ desugarDefine d) (loop rest)+ loop (LRec d:rest) = mkCall (mkDefn $ desugarLetrec d) (loop rest)+ loop (Open e:rest) = mkCall (mkOpen $ desugar e) (loop rest)+ loop (Expr e:rest) = mkCall (mkExpr $ desugar e) (loop rest)+desugar x = error $ "INTERNAL ERROR Octopus.Parser.desugar: " ++ show x++desugarField :: (Symbol, Syx) -> (Symbol, Val)+desugarField (k, e) = (k, desugar e)++desugarDefine :: Defn Syx -> (Val, Val)+desugarDefine (x, e) = (desugar x, desugar e)++desugarLetrec :: Defn Syx -> (Val, Val)+desugarLetrec (x, e) = let f = desugar x+ in (f, mkCall (mkSy "__Y__") (mkCall (mkCall (mkSy "__lambda__") f) (desugar e)))++desugarStatement :: Statement Syx -> Statement Val+desugarStatement (Defn d) = Defn (desugarDefine d)+desugarStatement (LRec d) = Defn (desugarLetrec d)+desugarStatement (Expr e) = Expr (desugar e)+desugarStatement (Open e) = Open (desugar e)+desugarStatement (Deco f) = Deco (desugar f)+++------ Atoms ------+primitive :: Parser Val+primitive = P.choice (map mkPrimParser table)+ where+ mkPrimParser (name, val) = string ("#<" ++ name ++ ">") >> return val+ table = [ ("vau", Pr Vau), ("eval", Pr Eval), ("match", Pr Match), ("ifz!", Pr Ifz), ("import", Pr Imp)+ , ("eq", Pr Eq), ("neq", Pr Neq), ("lt", Pr Lt), ("lte", Pr Lte), ("gt", Pr Gt), ("gte", Pr Gte)+ , ("add", Pr Add) , ("mul", Pr Mul) , ("sub", Pr Sub) , ("div", Pr Div)+ , ("numer", Pr Numer) , ("denom", Pr Denom) , ("numParts", Pr NumParts)+ , ("openFile", Pr OpenFp), ("flush", Pr FlushFp), ("close", Pr CloseFp)+ , ("readByte", Pr ReadFp), ("writeByte", Pr WriteFp)+ , ("mkTag", Pr MkTag)+ , ("len", Pr Len) , ("cat", Pr Cat) , ("cut", Pr Cut)+ , ("extends", Pr Extends) , ("del", Pr Delete) , ("keys", Pr Keys) , ("get", Pr Get)+ , ("handle", Pr Handle) , ("raise", Pr Raise)++ , ("stdin", fpStdin), ("stdout", fpStdout), ("stdin", fpStderr)++ , ("TypeError", exnTypeError), ("MatchFail", exnMatchFail)+ , ("ScopeError", exnScopeError), ("AttrError", exnAttrError), ("IndexError", exnIndexError)+ , ("DivZero", exnDivZero), ("IOError", exnIOError)+ , ("SyntaxError", exnSyntaxError), ("ImportError", exnImportError)+ ]++symbol :: Parser Val+symbol = do+ n <- name+ when (n `elem` ["do", "letrec", "export", "open"])+ (unexpected $ "reserved word (" ++ n ++ ")") --FIXME report error position before token, not after+ return $ mkSy n++numberLit :: Parser Val+numberLit = Nm <$> anyNumber++--TODO maybe bytes literals++textLit :: Parser Val+textLit = do+ content <- catMaybes <$> between2 (char '\"') (P.many maybeLiteralChar)+ return $ mkTx content++heredoc :: Parser Val+heredoc = do+ string "#<<"+ end <- P.many1 P.letter <* char '\n'+ let endParser = char '\n' *> P.string (end ++ ">>") <* (void (char '\n') P.<|> eof)+ mkTx <$> anyChar `manyThru` endParser+++------ Composites ------+combine :: Parser Syx+combine = do+ postPadded $ char '('+ e <- bareCombination+ padded $ char ')'+ return e++sq :: Parser Syx+sq = do+ postPadded $ char '['+ elems <- bareCombination `P.sepBy` padded comma+ padded $ char ']'+ return $ SqSyx elems++ob :: Parser Syx+ob = do+ postPadded $ char '{'+ elems <- pair `P.sepBy` padded comma+ padded $ char '}'+ return $ ObExpr elems+ where+ pair = do+ key <- intern <$> padded name+ char ':' <* whitespace+ val <- bareCombination+ return (key, val)++block :: Parser Syx+block = do+ try $ string "do" >> whitespace+ states <- P.many1 $ postPadded statement+ char ';'+ return $ Do states++quote :: Parser Syx+quote = do+ char '`'+ e <- expr+ return $ Call [Lit $ mkSy "__quote__", e]++dottedExpr :: Parser Syx+dottedExpr = Infix <$> (char '.' *> expr)++accessor :: Parser Syx+accessor = do+ key <- try $ char '@' *> name+ return $ Call [Lit $ mkSy "__get__", Lit $ mkSy key]++mutator :: Parser Syx+mutator = do+ string "@("+ key <- name <* char ':' <* whitespace+ e <- bareCombination+ char ')'+ return $ Call [Lit $ mkSy "__modify__", Lit $ mkSy key, e]++infixAccessor :: Parser Syx+infixAccessor = do+ key <- try $ char ':' *> name+ return . Infix $ Call [Lit $ mkSy "__get__", Lit $ mkSy key]++infixMutator :: Parser Syx+infixMutator = do+ string ":("+ key <- name <* char ':' <* whitespace+ e <- bareCombination + char ')'+ return . Infix $ Call [Lit $ mkSy "__modify__", Lit $ mkSy key, e]+++------ Space ------+whitespace :: Parser ()+whitespace = (<?> "space") . P.skipMany1 $ P.choice [spaces1, lineComment, blockComment]++lineComment :: Parser ()+lineComment = void $ do+ try $ char '#' >> P.notFollowedBy (oneOf "{<")+ anyChar `manyThru` (void (char '\n') P.<|> eof)++blockComment :: Parser ()+blockComment = P.between (string "#{") (string "}#") $ P.skipMany $+ P.choice [ void $ P.many1 (noneOf "}#")+ , blockComment+ , void $ try $ char '#' >> P.notFollowedBy (char '{')+ , void $ try $ char '}' >> P.notFollowedBy (char '#')+ ]++padded :: Parser a -> Parser a+padded p = try $ P.optional whitespace >> p+postPadded :: Parser a -> Parser a+postPadded p = p <* P.optional whitespace+++------ Helpers ------+name :: Parser String+name = P.choice [ (:) <$> namehead <*> nametail+ , (:) <$> char '-' <*> P.option [] ((:) <$> (namehead P.<|> char '-') <*> nametail)+ ]+ where+ namehead = blacklistChar (`elem` reservedFirstChar)+ nametail = P.many $ blacklistChar (`elem` reservedChar)+ reservedChar = "#\\\"`()[]{}@:;.,"+ reservedFirstChar = reservedChar ++ "-0123456789"++comma :: Parser ()+comma = char ',' >> whitespace++bareCombination :: Parser Syx+bareCombination = do+ es <- P.many1 (postPadded expr)+ return $ case es of { [e] -> e; es -> Call es }++mkDefn (x, val) = mkCall (mkCall (mkSy "__let__") x) val+mkOpen env = mkCall (mkSy "__open__") env+mkExpr e = mkCall (mkCall (mkSy "__let__") (mkOb [])) e+++
+ Language/Octopus/Parser/Preprocess.hs view
@@ -0,0 +1,18 @@+module Language.Octopus.Parser.Preprocess where++import Import++birdsFeet :: String -> String+birdsFeet input = unlines $ xformLine <$> lines input+ where+ xformLine l | "> " `isPrefixOf` l = " " ++ drop 2 l+ | otherwise = ""++partitionCode :: String -> ([String], String)+partitionCode input = case lines input of+ [] -> ([], input)+ x:xs -> loop [] [x] xs+ where+ loop dirs acc [] = (reverse dirs, unlines $ reverse acc)+ loop dirs acc (x:xs) = if isDirective x then loop (x:dirs) ("":acc) xs else loop dirs (x:acc) xs+ isDirective = isPrefixOf "#!"
+ Language/Octopus/Primitive.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Octopus.Primitive (+ resolveSymbol++ , match+ , ifz++ , eq, neq, lt, gt, lte, gte++ , add, sub, mul, div--, quo, rem, quorem+ + , numer, denom, numParts+ + --TODO float arithmetic (exp, log, ln, trig)++ , openFp, readFp, writeFp, flushFp, closeFp++ --, newTag++ , len, cat, cut++ , get, keys, extend, delete++ --, new, deref, assign++ --, newArr, getIx, setIx++ --TODO os interface (perhaps in a separate file)+ ) where++import Prelude hiding (div, rem)+import Import hiding (delete)+import qualified Data.Sequence as Seq+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.ByteString as BS+import System.IO.Error++import Language.Octopus.Data+import Language.Octopus.Data.Shortcut+import Language.Octopus.Basis+++------ Internals ------+{-| Lookup symbol in a value, if the binding exists. -}+resolveSymbol :: Symbol -> Val -> Maybe Val+resolveSymbol sy (Ob ob) = Map.lookup sy ob+resolveSymbol _ _ = Nothing+++------ Non-data Primitives ------+{-| Create a new environment by matching the second value+ to atoms in the first, even if those atoms are nested+ under sequences or objects. Symbols match any value and+ perform binding.+-}+match :: Val -> Val -> Fallible Val+--FIXME disallow double-binding+match var val = mkOb <$> go var val+ where+ go :: Val -> Val -> Fallible [(Symbol, Val)]+ go (Sy x) v = Right [(x, v)]+ go (Sq ps) (Sq xs) | Seq.length ps == Seq.length xs =+ concat <$> mapM (uncurry go) (zip (toList ps) (toList xs))+ | otherwise = Left $ mkMatchFail (Sq ps) (Sq xs)+ go (Sq ps) v = Left $ mkMatchFail (Sq ps) v+ go (Ob ps) _ | length (Map.keys ps) == 0 = Right []+ go (Ob ps) (Ob vs) = goObj (Map.toList ps) vs+ where+ goObj :: [(Symbol, Val)] -> Map Symbol Val -> Fallible [(Symbol, Val)]+ goObj [] _ = Right []+ goObj ((k, v):ks) vs = case Map.lookup k vs of+ Just v' -> (++) <$> go v v' <*> goObj ks vs+ Nothing -> Left $ mkMatchFail (Ob ps) (Ob vs)+ go (Ob ps) v = Left $ mkMatchFail (Ob ps) v+ go pat val = error $ "unimplemented pattern-matching:\n" ++ show pat ++ "\n" ++ show val++ifz :: Val -> Val -> Val -> Val+ifz (Nm x) | x == 0 = const+ | otherwise = ignore+--TODO float test vs. zero+ifz _ = ignore+ignore x y = y+++------ Relational ------+eq :: Val -> Val -> Fallible Val+eq a b = Right . mkInt $ if a == b then 1 else 0++neq :: Val -> Val -> Fallible Val+neq a b = Right . mkInt $ if a /= b then 1 else 0++lt :: Val -> Val -> Fallible Val+lt (Nm a) (Nm b) = Right . mkInt $ if a < b then 1 else 0++lte :: Val -> Val -> Fallible Val+lte (Nm a) (Nm b) = Right . mkInt $ if a <= b then 1 else 0++gt :: Val -> Val -> Fallible Val+gt (Nm a) (Nm b) = Right . mkInt $ if a > b then 1 else 0++gte :: Val -> Val -> Fallible Val+gte (Nm a) (Nm b) = Right . mkInt $ if a >= b then 1 else 0+++------ Arithmetic ------+add :: Val -> Val -> Fallible Val+add (Nm a) (Nm b) = Right . Nm $ a + b+add a b = Left $ mkTypeError (Pr Add) "(Nm, Nm)" (mkSq [a, b])++sub :: Val -> Val -> Fallible Val+sub (Nm a) (Nm b) = Right . Nm $ a - b+sub a b = Left $ mkTypeError (Pr Sub) "(Nm, Nm)" (mkSq [a, b])++mul :: Val -> Val -> Fallible Val+mul (Nm a) (Nm b) = Right . Nm $ a * b+mul a b = Left $ mkTypeError (Pr Mul) "(Nm, Nm)" (mkSq [a, b])++div :: Val -> Val -> Fallible Val+div (Nm a) (Nm b) | b == 0 = Left (getTag exnDivZero, exnDivZero)+ | otherwise = Right . Nm $ a / b+div a b = Left $ mkTypeError (Pr Div) "(Nm, Nm)" (mkSq [a, b])++--quo :: Val -> Val -> Maybe Val+--quo = error "TODO"++--rem :: Val -> Val -> Maybe Val+--rem = error "TODO"++--quorem :: Val -> Val -> Maybe Val+--quorem = error "TODO"+++------ Rationals ------+numer :: Val -> Fallible Val+numer (Nm n) = Right . mkInt $ numerator n+numer x = Left $ mkTypeError (Pr Numer) "Nm" x++denom :: Val -> Fallible Val+denom (Nm n) = Right . mkInt $ denominator n+denom x = Left $ mkTypeError (Pr Denom) "Nm" x++numParts :: Val -> Fallible Val+numParts (Nm n) = let (whole, frac) = properFraction n+ in Right $ mkSq [mkInt whole, Nm frac]+--TODO get (whole, mantissa)+numParts x = Left $ mkTypeError (Pr NumParts) "Nm | Fl" x+++------ Floats ------+++------ Handles ------+openFp :: Val -> IO (Fallible Val)+openFp (Sq args) = case toList args of+ [Tx path, Sy m] -> do+ fp_m <- tryIOError $ openBinaryFile (unpack path) (mode m)+ case fp_m of+ Right fp -> return . Right $ Fp fp+ Left err -> return . Left $ (getTag exnIOError, mkSq [exnIOError, mkTx $ show err])+ _ -> return . Left $ mkTypeError (Pr OpenFp) "(Tx, { mode ← mode ∈ [`r, `w, `rw, `a] })" (Sq args)+ where+ mode m = case unintern m of+ "r" -> ReadMode+ "w" -> WriteMode+ "a" -> AppendMode+ "rw" -> ReadWriteMode+ _ -> error "TODO Type error"+openFp args = return . Left $ mkTypeError (Pr OpenFp) "(Tx, { mode ← mode ∈ [`r, `w, `rw, `a] })" args++readFp :: Val -> IO (Fallible Val)+readFp (Fp fp) = do+ c_m <- tryIOError $ hGetChar fp+ return $ case c_m of+ Right c -> Right $ mkInt (ord c)+ Left err -> Left $ (getTag exnIOError, mkSq [exnIOError, mkTx $ show err])+readFp x = return . Left $ mkTypeError (Pr OpenFp) "Fp" x++writeFp :: Val -> IO (Fallible Val)+writeFp (Sq args) = case toList args of+ [Fp fp, x] -> case ensureByte x of+ Right byte -> do+ success <- tryIOError $ hPutChar fp byte+ return $ case success of+ Right () -> Right $ mkOb []+ Left err -> Left $ (getTag exnIOError, mkSq [exnIOError, mkTx $ show err])+ Left err -> return . Left $ mkTypeError (Pr WriteFp) "(Fp, Byte)" (Sq args)+ _ -> return . Left $ mkTypeError (Pr WriteFp) "(Fp, Byte)" (Sq args)+ where+ ensureByte (Nm q) | denominator q == 1 =+ let n = numerator q+ in if 0 <= n && n < 256+ then Right (chr $ fromIntegral n)+ else Left $ mkTypeError (Pr WriteFp) "(Fp, Byte)" (Sq args)+ ensureByte _ = Left $ mkTypeError (Pr WriteFp) "(Fp, Byte)" (Sq args)+writeFp args = return . Left $ mkTypeError (Pr WriteFp) "(Fp, Byte)" args++flushFp :: Val -> IO (Fallible Val)+flushFp (Fp fp) = do+ success <- tryIOError $ hFlush fp+ return $ case success of+ Right () -> Right $ mkOb []+ Left err -> Left $ (getTag exnIOError, mkSq [exnIOError, mkTx $ show err])+flushFp x = return . Left $ mkTypeError (Pr FlushFp) "Fp" x++closeFp :: Val -> IO (Fallible Val)+closeFp (Fp fp) = do+ hClose fp+ return . Right $ mkOb []+closeFp x = return . Left $ mkTypeError (Pr CloseFp) "Fp" x++------ Sequence/Text/Bytes ------+len :: Val -> Fallible Val+len (Sq xs) = Right . mkInt $ Seq.length xs+len (Tx xs) = Right . mkInt $ T.length xs+len (By xs) = Right . mkInt $ BS.length xs+len x = Left $ mkTypeError (Pr Len) "Sq * | Tx | By" x++cat :: Val -> Val -> Fallible Val+cat (Sq xs) (Sq ys) = Right . Sq $ xs <> ys+cat (Tx xs) (Tx ys) = Right . Tx $ xs <> ys+cat (By xs) (By ys) = Right . By $ xs <> ys+cat x y = Left $ mkTypeError (Pr Cat) "∀ f :: Sq * | Tx | By. (f, f)" (mkSq [x, y])++cut :: Val -> Val -> Fallible Val --FIXME I guess I really need to return (Either Val Val), where the left is an exception to raise+cut x (Nm q) = + case x of+ Sq xs -> do+ i <- n+ when (i >= Seq.length xs) $ ixErr+ let (as, bs) = Seq.splitAt i xs+ Right $ mkSq [Sq as, Sq bs]+ Tx xs -> do+ i <- n+ when (i >= T.length xs) $ ixErr+ let (as, bs) = T.splitAt i xs+ Right $ mkSq [Tx as, Tx bs]+ By xs -> do+ i <- n+ when (i >= BS.length xs) $ ixErr+ let (as, bs) = BS.splitAt i xs+ Right $ mkSq [By as, By bs]+ _ -> Left $ mkTypeError (Pr Cut) "(Sq * | Tx | By, Nat)" (mkSq [x, Nm q])+ where+ n = if denominator q == 1+ then Right (fromIntegral $ numerator q)+ else Left $ mkTypeError (Pr Cut) "(Sq * | Tx | By, Nat)" (mkSq [x, Nm q])+ ixErr = Left (getTag exnIndexError, mkSq [exnIndexError, Nm q, x])+cut xs n = Left $ mkTypeError (Pr Cut) "(Sq * | Tx | By, Nat)" (mkSq [xs, n])+++------ Xons ------+{-| @get x f@ retrieves field @f@ from @x@, if the field exists. -}+get :: Val -> Val -> Fallible Val+get (Ob ob) (Sy sy) = maybe (Left (getTag exnAttrError, mkSq [exnAttrError, Sy sy, Ob ob])) Right $ Map.lookup sy ob+get ob sy = Left $ mkTypeError (Pr Get) "(Ob, Sy)" (mkSq [ob, sy])++{-| Get a list of the fields in a value. -}+keys :: Val -> Fallible Val+keys (Ob ob) = Right . mkSq $ Sy <$> Map.keys ob+keys _ = Right $ mkSq []++{-| @extend a b@ extends and overwrites bindings in @b@ with bindings in @a@. -}+extend :: Val -> Val -> Val+extend (Ob ob') (Ob ob) = Ob $ Map.union ob' ob+extend _ (Ob ob) = Ob ob+extend (Ob ob') _ = Ob ob'+extend _ _ = mkOb []++{-| @delete x f@ removes field @f@ from @x@, if the field exists.+ If it does not exist, then there is no change.+-}+delete :: Val -> Val -> Fallible Val+delete (Ob ob) (Sy sy) = Right . Ob $ Map.delete sy ob+delete x _ = Right x++++
− Octopus.hs
@@ -1,175 +0,0 @@-module Octopus where--import Import-import qualified Data.Sequence as Seq-import qualified Data.Map as Map--import Control.Monad.State-import Control.Monad.Reader-import System.IO.Error-import Control.Concurrent.MVar--import Octopus.Data-import Octopus.Parser (parseOctopusFile)-import qualified Octopus.Primitive as Oct-import Octopus.Basis-import Octopus.Shortcut-import Octopus.Libraries---eval :: ImportsCache -> Val -> Val -> IO Val-eval cache env code = evalStateT (runReaderT (reduce code) cache) startState- where- startState = MState { environ = env --Ob Map.empty- , control = [NormK []]- }---reduce :: Val -> Machine Val-reduce x@(Nm _) = done x-reduce x@(By _) = done x-reduce x@(Tx _) = done x-reduce x@(Fp _) = done x-reduce x@(Tg _) = done x-reduce x@(Ab _ _) = done x-reduce x@(Cl _ _ _) = done x-reduce x@(Ce _) = done x-reduce x@(Ar _) = done x-reduce x@(Pr _) = done x-reduce sq@(Sq xs) = case toList xs of- [] -> done sq- (x:xs) -> push (Es [] xs) >> reduce x-reduce ob@(Ob m) = case ensureCombination ob of- Just (f, x) -> push (Op x) >> reduce f- Nothing -> case Map.toList m of- [] -> done (mkOb [])- ((k,v):xs) -> push (Eo k [] xs) >> reduce v-reduce (Sy x) = gets environ >>= \env -> case Oct.resolveSymbol x env of- Just val -> done val- Nothing -> do- env <- gets environ- error $ "TODO unbound symbol: " ++ show x ++ "\n" ++ show env--combine :: Val -> Val -> Machine Val-combine (Pr Vau) x = case x of- Sq xs -> case toList xs of- [var, ast] -> do- env <- gets environ- done $ Cl var ast env- _ -> error "raise wrong number of args to primitive vau"- _ -> error "raise invalid args to primitive vau"-combine f@(Pr _) x = push (Ap f) >> reduce x-combine f x = case ensureClosure f of --all of these are operatives- Just (var, ast, env) -> do- caller <- gets environ- let x' = mkSq [caller, x]- case Oct.match var x' of- Right env' -> swapEnv (env' `Oct.extend` env) >> reduce ast- Left err -> error "raise match failure"- _ -> error $ "raise not a combiner:\n" ++ show f--apply :: Val -> Val -> Machine Val-apply (Pr Eval) x = case ensureThunk x of- Just (env, ast) -> swapEnv env >> reduce ast- _ -> error $ "raise invalid args to primitive eval: " ++ show x-apply (Pr Ifz) x = case x of- Sq xs -> case toList xs of- [p, c, a] -> done $ Oct.ifz p c a- _ -> error "raise wrong number of args to primitive Ifz"- _ -> error "raise invalid args to primitive Ifz"-apply (Pr Imp) x = impFile x-apply (Pr Extends) x = case x of- Sq xs -> case toList xs of- [] -> done $ mkOb []- xs -> done $ foldr1 Oct.extend xs- _ -> error "raise invalid args to primitive Extends"-apply (Pr pr) x =- case lookup pr table of- Just f -> case f pr x of- Right val -> done val- Left err -> error $ "raise some error in primitive " ++ show pr- Nothing -> error $ "unknown primitive " ++ show pr- where- table = - [ (Match, binary Oct.match)- - , (Delete, binary Oct.delete)- , (Keys, unary Oct.keys)- , (Get, binary Oct.get)- - , (Eq, binary Oct.eq)- , (Neq, binary Oct.neq)- , (Lt, binary Oct.lt)- , (Lte, binary Oct.lte)- , (Gt, binary Oct.gt)- , (Gt, binary Oct.gt)- - , (Add, binary Oct.add)- , (Sub, binary Oct.sub)- , (Mul, binary Oct.mul)- , (Div, binary Oct.div)- - , (Len, unary Oct.len)- , (Cat, binary Oct.cat)- , (Cut, binary Oct.cut)- - , (Numer, unary Oct.numer)- , (Denom, unary Oct.denom)- , (NumParts, unary Oct.numParts)- ]- binary :: (Val -> Val -> Fallible Val) -> Primitive -> Val -> Fallible Val- binary op pr x = case x of- Sq xs -> case toList xs of- [a, b] -> op a b- _ -> error $ "raise wrong number of args to primitive " ++ show pr- _ -> error $ "raise invalid args to primitive " ++ show pr- unary :: (Val -> Fallible Val) -> Primitive -> Val -> Fallible Val- unary op pr x = op x-apply f x = error "TODO apply"--done :: Val -> Machine Val-done x = do- k <- gets control- case k of- [] -> return x- (NormK []):_ -> pop >> done x- (NormK (Re _:_)):_ -> pop >> done x- (NormK (Es xs []:_)):_ -> pop >> done (Sq . Seq.fromList $ reverse (x:xs))- (NormK (Es xs (x':xs'):_)):_ -> replace (Es (x:xs) xs') >> reduce x'- (NormK (Eo k xs []:_)):_ -> pop >> done (Ob . Map.fromList $ (k,x):xs)- (NormK (Eo k xs ((k',x'):xs'):_)):_ -> replace (Eo k' ((k,x):xs) xs') >> reduce x'- (NormK (Op arg:ks)):kss -> pop >> combine x arg- (NormK (Ap f:ks)):kss -> pop >> apply f x- (ImptK _ slot):ks -> liftIO (slot `putMVar` Right x) >> pop >> done x---impFile :: Val -> Machine Val-impFile (Tx pathstr) = do- let path = pathstr --FIXME normalize path- path' = unpack path- --TODO check against builtin files, or else pre-populate the cache- --TODO check the path against the current imports on stack to avoid circular import- cache_var <- ask- cache <- liftIO $ takeMVar cache_var- case Map.lookup path cache of- Just loaded_var -> do- liftIO $ cache_var `putMVar` cache- val_e <- liftIO $ readMVar loaded_var- case val_e of- Right val -> done val- Left err -> error $ "raise exception " ++ show err- Nothing -> do- loading_var <- liftIO newEmptyMVar- liftIO $ cache_var `putMVar` Map.insert path loading_var cache- contents_e <- liftIO $ tryIOError $ readFile path'- case contents_e of- Right contents -> do- swapEnv startData- pushK (ImptK path loading_var)- case parseOctopusFile path' contents of- Right val -> reduce val --TODO consider which env to start a file off with- Left err -> error "raise SyntaxError" --FIXME also don't forget to fill the loading_var- Left err -> error "raise ImportError" --FIXME also don't forget to fill the loading_var-impFile _ = error "TODO raise TypeError"--
− Octopus/Basis.hs
@@ -1,98 +0,0 @@-{-| This module contains values that help create and manipulate Octopus- values that are used by the interpreter, but not strictly primitive,- that is, they could just as easily be defined in user-space, as long- as the machine could get at them.--}-module Octopus.Basis (- mkVau- -- * Basic Protocols- -- ** Combination- , mkCall- , callOpr- , callArg- , ensureCombination- -- ** Closure- , mkClosure- , ensureClosure- -- ** Suspension- , mkThunk- , ensureThunk-- , module Octopus.Shortcut- ) where--import Import-import qualified Data.Sequence as Seq-import qualified Data.Map as Map--import Octopus.Data-import Octopus.Shortcut---mkVau :: String -> String -> Val -> Val-mkVau e arg body = mkCall (Pr Vau) (mkSq [mkSq [Sy $ intern e, Sy $ intern arg], body])---{-| Construct a combination: an object with a- @__car__@ slot and a @__cdr__@ slot.--}-mkCall :: Val -- ^ Combiner (@__car__@)- -> Val -- ^ Argument (@__cdr__@)- -> Val-mkCall f x = mkOb [(callOpr, f), (callArg, x)]--{-| Extract a (combiner, argument) pair from a- combination-responsive object.--}-ensureCombination :: Val -> Maybe (Val, Val)-ensureCombination (Ob ob) = (,) <$> Map.lookup callOpr ob- <*> Map.lookup callArg ob-ensureCombination _ = Nothing--{-| Combiner slot name in a combination (aka. application) -}-callOpr :: Symbol-callOpr = intern "__car__"-{-| Argument slot name in a combination (aka. application) -}-callArg :: Symbol-callArg = intern "__cdr__"---{-| Construct a closure: an object with @__var__@,- @__ast__@ and @__env__@ slots.--}-mkClosure :: Val -- ^ Body (@__ast__@)- -> Val -- ^ Static environment (@__env__@)- -> Val -- ^ Parameter (@__arg__@)- -> Val-mkClosure var ast env = Cl var ast env--{-| Extract a (body, environment, parameter) triple from- a closure-responsive object.--}-ensureClosure :: Val -> Maybe (Val, Val, Val)-ensureClosure (Cl var ast env) = Just (var, ast, env)-ensureClosure _ = Nothing---{-| Construct a thunk: a (environment, body) pair. -}-mkThunk :: Val -- ^ Environment (second element)- -> Val -- ^ Body (first element)- -> Val-mkThunk env ast = Sq $ Seq.fromList [env, ast]--{-| Extract a (environment, body) pair from a thunk-responsive pair. -}-ensureThunk :: Val -> Maybe (Val, Val)-ensureThunk (Sq xs) = case toList xs of- [env, ast] -> Just (env, ast)- _ -> Nothing-ensureThunk _ = Nothing----------
− Octopus/Data.hs
@@ -1,132 +0,0 @@-module Octopus.Data where--import Import-import qualified Data.Sequence as Seq-import qualified Data.Map as Map-import Control.Monad.Reader-import Control.Monad.State-import Control.Concurrent.MVar (MVar)---type Fallible = Either Val---data Val = Nm Rational -- ^ Rational number- | By ByteString -- ^ Bytes- | Tx Text -- ^ Text data- | Fp Handle -- ^ Input/output handle- | Sy Symbol -- ^ Symbol, aka. identifier- | Tg Word -- ^ Unique tag- | Ab Word Val -- ^ Abstract data- | Sq (Seq Val) -- ^ Sequence, aka. list- | Ob (Map Symbol Val) -- ^ Symbol-value map, aka. object- | Cl Val Val Val -- ^ Operative closure- | Ce (IORef Val) -- ^ Reference cell- | Ar (IOArray Int Val) -- ^ Mutable array- | Pr Primitive -- ^ Primitive operations- | Pt Int -- ^ Control prompt --TODO consider removing this in favor of using tags and a handler protocol- | Ks [Control] -- ^ Control stack - --TODO bytestring/buffer/bytes/other name?- --TODO concurrency- deriving (Eq)-data Primitive = Vau | Eval | Match | Ifz | Imp- | Eq | Neq | Lt | Lte | Gt | Gte- | Add | Mul | Sub | Div- | Numer | Denom | NumParts- --TODO By data primitives- --TODO Tx data primitives- --TODO Fp data primitives- --TODO Sy data primitives- --TODO Tg data primitives- | Wrap Word | Unwrap Word- | Len | Cat | Cut- | Extends | Delete | Keys | Get- --TODO Ce data primitives- --TODO Ar data primitives- --TODO Pt/Ks data primitives- deriving (Eq, Show)----type FileCache = MVar (Either Val Val)-type ImportsCache = MVar (Map Text FileCache)-data MState = MState { environ :: Val, control :: [Control] }--type Machine = ReaderT ImportsCache (StateT MState IO)---data Context = Op Val -- ^ Hole must be a combiner, val is the uneval'd argument- | Ap Val -- ^ Hole is the argument, apply held value to it- | Re Val -- ^ Restore an environment before continuing- | Es [Val] [Val] -- ^ Left-to-right sequence evaluation- | Eo Symbol [(Symbol, Val)] [(Symbol, Val)] -- ^ Object evaluation- deriving (Eq, Show)-data Control = NormK [Context]- | HndlK Val- --TODO onEnter/onSuccess/onFail- | ImptK Text (MVar (Fallible Val))- deriving (Eq)-instance Show Control where- show (NormK k) = "NormK " ++ show k- show (HndlK x) = "HndlK " ++ show x- show (ImptK path slot) = "ImptK " ++ show path---push :: Context -> Machine ()-push k = do- (NormK ks):kss <- gets control- modify $ \s -> s { control = (NormK (k:ks)):kss }- --FIXME remember that when I push a handler or a winding protect, I also need to push an environment restore-pushK :: Control -> Machine ()-pushK k@(NormK _) = do- ks <- gets control- modify $ \s -> s { control = k:ks }-pushK k = do- ks <- gets control- modify $ \s -> s { control = (NormK []):k:ks }-pop :: Machine ()-pop = do- stack <- gets control- case stack of- (NormK []):kss -> modify $ \s -> s { control = kss }- (NormK (Re env:ks)):kss -> modify $ \s -> s { environ = env, control = (NormK ks):kss }- (NormK (_:ks)):kss -> modify $ \s -> s { control = (NormK ks):kss }- (ImptK _ _):ks -> modify $ \s -> s { control = ks }-replace :: Context -> Machine ()-replace k = do- stack <- gets control- case stack of- (NormK []):kss -> modify $ \s -> s { control = (NormK [k]):kss }- (NormK (_:ks)):kss -> modify $ \s -> s { control = (NormK (k:ks)):kss }- (ImptK _ _):ks -> pop >> replace k-swapEnv :: Val -> Machine ()-swapEnv env' = do- env <- gets environ- (NormK ks):kss <- gets control- case ks of- (Re _):_ -> modify $ \s -> s { environ = env' } --allows tail recursion by not restoring environments that will immediately be thrown away by a second restoration- ks -> modify $ \s -> s { environ = env', control = (NormK ((Re env):ks)):kss }---instance Show Val where- show (Nm nm) | denominator nm == 1 = show $ numerator nm- | otherwise = show (numerator nm) ++ "/" ++ show (denominator nm)- show (By bytes) = "b" ++ show bytes --FIXME show with \x?? for non-ascii printable chars- show (Tx text) = show text --FIXME show using Octopus encoding, not Haskell- show (Fp _) = "<handle>" --TODO at least show some metadata- show (Sy sy) = show sy- show (Tg i) = "<tag: " ++ show i ++ ">"- show (Ab tag x) = "<box " ++ show tag ++ ": " ++ show x ++ ">"- show (Sq xs) = "[" ++ intercalate ", " (show <$> toList xs) ++ "]"- show (Ob m) = case getCombo m of- Nothing -> "{" ++ intercalate ", " (showPair <$> Map.toList m) ++ "}"- Just (f, x) -> "(" ++ show f ++ " " ++ show x ++ ")"- where- showPair (k,v) = show k ++ ": " ++ show v- getCombo ob = case (Map.lookup (intern "__car__") ob, Map.lookup (intern "__cdr__") ob) of- (Just f, Just x) -> if length (Map.keys ob) == 2 then Just (f, x) else Nothing- _ -> Nothing- show (Cl var ast env) = "<closure: var: " ++ show var ++ ", ast: " ++ show ast ++ ", env: " ++ show env ++ ">"- show (Ce x) = "<reference cell>" --TODO show contents- show (Ar xs) = "<mutable array>" --TODO show contents- show (Pr f) = "<" ++ show f ++ ">"
− Octopus/Libraries.hs
@@ -1,94 +0,0 @@-module Octopus.Libraries where--import Import-import Octopus.Data-import Octopus.Basis---startData = mkOb [- --- Non-data ---- (intern "__vau__", Pr Vau)- , (intern "__match__", Pr Match)- , (intern "__eval__", Pr Eval)- , (intern "__ifz!__", Pr Ifz)- , (intern "__import__", Pr Imp)- --- Relationals ---- , (intern "__eq__", Pr Eq)- , (intern "__neq__", Pr Neq)- , (intern "__lt__", Pr Lt)- , (intern "__lte__", Pr Lte)- , (intern "__gt__", Pr Gt)- , (intern "__gte__", Pr Gt)- --- Arithmetic ---- , (intern "__add__", Pr Add)- , (intern "__mul__", Pr Mul)- , (intern "__sub__", Pr Sub)- , (intern "__div__", Pr Div)- --- Numbers ---- , (intern "__numer__", Pr Numer)- , (intern "__denom__", Pr Denom)- , (intern "__numparts__", Pr NumParts)- --- Lists ---- , (intern "__len__", Pr Len)- , (intern "__cat__", Pr Cat)- , (intern "__cut__", Pr Cut)- --- Xonses ---- , (intern "__extends__", Pr Extends)- , (intern "__del__", Pr Delete)- , (intern "__keys__", Pr Keys)- --TODO __lookup__- --- Niceties ---- , (intern "vau", vauDef)- , (intern "__get__", getDef)- , (intern "__let__", letDef)- , (intern "__lambda__", lambdaDef)- , (intern "__quote__", quoteDef)- ]--vauDef = Cl- (mkSq [mkOb [], mkSy "x"])- (mkCall (Pr Vau) (mkSq [mkSq [mkSy "static", mkSy "body"],- mkCall (Pr Vau) (mkSq [mkSy "arg",- mkCall (Pr Eval) (mkSq [- mkCall (Pr Extends) (mkSq [- mkCall (Pr Match) (mkSq [mkSy "x", mkSy "arg"]),- mkSy "static"]),- mkSy "body"])])]))- (mkOb [])---delDef = Cl - (mkSy "ob")- (mkCall (Pr Vau) (mkSq [mkSq [mkOb [], mkSy "x"],- mkCall (Pr Delete) (mkSq [mkCall (Pr Eval) (mkSy "ob"), mkSy "x"])]))- (mkOb [])--getDef = Cl- (mkSq [mkOb [], mkSy "x"])- (mkCall (Pr Vau) (mkSq [mkSy "ob",- mkCall (Pr Eval) (mkSq [mkCall (Pr Eval) (mkSy "ob"), mkSy "x"])]))- (mkOb [])---letDef = Cl- (mkSq [mkOb [], mkSy "x"])- (mkCall (Pr Vau) (mkSq [mkSy "val",- mkCall (Pr Vau) (mkSq [mkSq [mkSy "e", mkSy "body"],- mkCall (Pr Eval) (mkSq- [ mkCall (Pr Extends) (mkSq - [ mkCall (Pr Match) (mkSq [mkSy "x", mkCall (Pr Eval) (mkSy "val")])- , mkSy "e"])- , mkSy "body"])])]))- (mkOb [])--lambdaDef = Cl- (mkSq [mkOb [], mkSy "var"])- (mkCall (Pr Vau) (mkSq [mkSq [mkSy "static", mkSy "ast"],- mkCall (Pr Vau) (mkSq [mkSy "arg",- mkCall (Pr Eval) (mkSq- [ mkCall (Pr Extends) (mkSq- [ mkCall (Pr Match) (mkSq [mkSy "var", mkCall (Pr Eval) (mkSy "arg")])- , mkSy "static"])- , mkSy "ast"])])]))- (mkOb [])-quoteDef = Cl (mkSq [mkOb [], mkSy "ast"]) (mkSy "ast") (mkOb [])
− Octopus/Parser.hs
@@ -1,211 +0,0 @@-{-| Parse Octopus source code. The Octopus grammar is:--@-file ::= (\<expr\> | \<defn\>)*-defn ::= _field_ \<expr\>-expr ::= \<atom\> | \<list\> | \<object\>- | \<combination\> | \<block\> | \<quotation\>- | '(' \<expr\> ')'--atom ::= _symbol_ | _number_ | _string_ | _heredoc_ | _accessor_-list ::= '[' (\<expr\>+ (',' \<expr\>+)*)? ']'-object ::= '{' (_field_ \<expr\>+ (',' _field_ \<expr\>+)*)? '}'-combination ::= '(' \<expr\> \<expr\>+ ')'-block ::= 'do' (\<expr\> | \<defn\>)+ ';'-quotation ::= '`' \<expr\>--symbol ::= \/\<name\>\/ - reserved- reserved = {'do'}-field ::= \/\<name\>:\/-accessor ::= \/:\<name\>\/-number ::= \/[+-]?(0[xX]\<hexnum\>|0[oO]\<octnum\>|0[bB]\<binnum\>|\<decnum\>)\/- decnum ::= \/\\d+(\\.\\d+\<exponent\>?|\\\/\\d+)?\/- hexnum ::= \/\\x+(\\.\\x+([hH][+-]?\\x+)?|\\\/\\x+)?\/- octnum ::= \/[0-7]+(\\.[0-7]+\<exponent\>?|\\\/[0-7]+)?\/- binnum ::= \/[01]+(\\.[01]+\<exponent\>?|\\\/[01]+)?\/- exponent ::= \/[eE][+-]?\\d+|[hH][+-]?\\x+\/-string ::= \/\"([^\\\\\"]|\\\\[abefntv\'\"\\\\&]|\\\\\<numescape\>|\\\\\\s*\\n\\s*\\\\)*\"\/- numescape ::= \/[oO][0-7]{3}|[xX][0-9a-fA-F]{2}|u[0-9a-fA-F]{4}|U0[0-9a-fA-F]{5}|U10[0-9a-fA-F]{4}\/-heredoc ::= \/\#\<\<\\s*(?\'END\'\\w+)\\s*\\n.*?\\g{END}\/-name ::= \/\<namehead\>\<nametail\>|-(\<namehead\>|-)\<nametail\>|-\/- nametail = \/[^\#\\\\\"`()[]{}:;.,]*\/- namehead = \/[^\#\\\\\"`()[]{}:;.,0-9-]\/--linecomment ::= \/#(?!\>\>)\\.*?\\n\/-blockcomment ::= \/\#\\{([^\#}]+|\<blockcomment\>|\#[^{]|\\}[^\#])*\\}\#\/-@--}-module Octopus.Parser where--import Import--import qualified Data.ByteString.Lazy as BS-import qualified Data.Text as T-import Text.Parsec ( Parsec, SourceName, ParseError- , try, (<?>), unexpected, parserZero- , char, anyChar, eof)-import qualified Text.Parsec as P-import Language.Parse--import Octopus.Data-import Octopus.Shortcut-import Octopus.Basis---type Parser = Parsec String ()--parseOctopusExpr :: SourceName -> String -> Either ParseError Val-parseOctopusExpr sourceName input = P.runParser (padded expr <* padded eof) () sourceName input--parseOctopusFile :: SourceName -> String -> Either ParseError Val-parseOctopusFile sourceName input = P.runParser octopusFile () sourceName input- where- octopusFile = do- es <- P.many $ padded statement- padded eof- return $ loop es- loop [] = mkCall getenv (mkOb [])- loop (Left s:rest) = mkCall (mkDefn s) (loop rest)- loop (Right e:rest) = mkCall (mkExpr e) (loop rest)- getenv = (mkCall (Pr Vau) (mkSq [mkSq [mkSy "e", mkOb []], mkSy "e"]))---define :: Parser (Val, Val)-define = do- var <- try (expr <* char ':' <* whitespace)- body <- expr- return (var, body)--expr :: Parser Val-expr = composite P.<|> atom- where- atom = P.choice [symbol, numberLit, textLit, heredoc, accessor] <?> "atom"- composite = P.choice [block, combine, sq, ob, quote]--statement :: Parser (Either (Val, Val) Val)-statement = (Left <$> define) P.<|> (Right <$> expr)--------- Atoms -------symbol :: Parser Val-symbol = do- n <- name- when (n == "do") (unexpected "reserved word (do)") --FIXME report error position before token, not after- return $ mkSy n--numberLit :: Parser Val-numberLit = Nm <$> anyNumber----TODO maybe bytes literals--textLit :: Parser Val-textLit = do- content <- catMaybes <$> between2 (char '\"') (P.many maybeLiteralChar)- return $ mkTxt content-mkBytes = By . encodeUtf8 . T.pack-mkTxt = Tx . T.pack--heredoc :: Parser Val-heredoc = do- string "#<<"- --grab until end of line, strip whitespace, save as `end`- --anyChar `manyThru` end- parserZero --TODO--accessor :: Parser Val-accessor = do- key <- char ':' *> name- return $ mkCall (mkSy "__get__") (mkSy key)--------- Composites -------combine :: Parser Val-combine = do- postPadded $ char '('- e <- bareCombination- padded $ char ')'- return e--sq :: Parser Val-sq = do- postPadded $ char '['- elems <- bareCombination `P.sepBy` padded comma- padded $ char ']'- return $ mkSq elems--ob :: Parser Val-ob = do- postPadded $ char '{'- elems <- pair `P.sepBy` padded comma- padded $ char '}'- return $ mkOb elems- where- pair = do- key <- intern <$> padded name- char ':' <* whitespace- val <- bareCombination- return (key, val)--block :: Parser Val-block = do- try $ string "do" >> whitespace- states <- P.many1 $ postPadded statement- char ';'- return $ loop states- where- loop [Left d] = mkCall (mkDefn d) (mkOb [])- loop [Right e] = e- loop (Left d:rest) = mkCall (mkDefn d) (loop rest)- loop (Right e:rest) = mkCall (mkExpr e) (loop rest)--quote :: Parser Val-quote = do- char '`'- e <- expr- return $ mkCall (mkSy "__quote__") e--------- Space -------whitespace :: Parser ()-whitespace = (<?> "space") . P.skipMany1 $ P.choice [spaces1, lineComment, blockComment]--lineComment :: Parser ()-lineComment = void $ do- try $ char '#' >> P.notFollowedBy (string "<<")- anyChar `manyThru` (void (char '\n') P.<|> eof)--blockComment :: Parser ()-blockComment = parserZero--padded :: Parser a -> Parser a-padded p = try $ P.optional whitespace >> p-postPadded :: Parser a -> Parser a-postPadded p = p <* P.optional whitespace--------- Helpers -------name :: Parser String-name = P.choice [ (:) <$> namehead <*> nametail- , (:) <$> char '-' <*> P.option [] ((:) <$> (namehead P.<|> char '-') <*> nametail)- ]- where- namehead = blacklistChar (`elem` reservedFirstChar)- nametail = P.many $ blacklistChar (`elem` reservedChar)- reservedChar = "#\\\"`()[]{}:;.,"- reservedFirstChar = reservedChar ++ "-0123456789"--comma :: Parser ()-comma = char ',' >> whitespace--bareCombination :: Parser Val-bareCombination = loop <$> P.many1 (postPadded expr)- where- loop [e] = e- loop [f, x] = mkCall f x- loop es = mkCall (loop $ init es) (last es)--mkDefn (x, val) = mkCall (mkCall (mkSy "__let__") x) val-mkExpr e = mkCall (mkCall (mkSy "__let__") (mkOb [])) e---
− Octopus/Primitive.hs
@@ -1,214 +0,0 @@-module Octopus.Primitive (- resolveSymbol-- , match- , ifz-- , eq, neq, lt, gt, lte, gte-- , add, sub, mul, div--, quo, rem, quorem- - , numer, denom, numParts- - --TODO float arithmetic (exp, log, ln, trig)-- --, read, write, flush, close-- --, newTag-- , len, cat, cut-- , get, keys, extend, delete-- --, new, deref, assign-- --, newArr, getIx, setIx-- --TODO os interface (perhaps in a separate file)- ) where--import Prelude hiding (div, rem)-import Import hiding (delete)-import qualified Data.Sequence as Seq-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.ByteString as BS--import Octopus.Data-import Octopus.Shortcut-import Octopus.Basis--------- Internals -------{-| Lookup symbol in a value, if the binding exists. -}-resolveSymbol :: Symbol -> Val -> Maybe Val-resolveSymbol sy (Ob ob) = Map.lookup sy ob-resolveSymbol _ _ = Nothing--------- Non-data Primitives -------{-| Create a new environment by matching the second value- to atoms in the first, even if those atoms are nested- under sequences or objects. Symbols match any value and- perform binding.--}-match :: Val -> Val -> Fallible Val---FIXME disallow double-binding-match var val = mkOb <$> go var val- where- go :: Val -> Val -> Fallible [(Symbol, Val)]- go (Sy x) v = Right [(x, v)]- go (Sq ps) (Sq xs) | Seq.length ps == Seq.length xs = do- concat <$> mapM (uncurry go) (zip (toList ps) (toList xs))- | otherwise = error "raise pattern match failure"- go (Sq ps) _ = Left (error "TODO")- go (Ob ps) _ | length (Map.keys ps) == 0 = Right []- go (Ob ps) (Ob vs) = goObj (Map.toList ps) vs- where- goObj :: [(Symbol, Val)] -> Map Symbol Val -> Fallible [(Symbol, Val)]- goObj [] _ = Right []- goObj ((k, v):ks) vs = case Map.lookup k vs of- Just v' -> (++) <$> go v v' <*> goObj ks vs- Nothing -> error "raise pattern match failure"- go pat val = error $ "unimplemented pattern-matching:\n" ++ show pat ++ "\n" ++ show val--ifz :: Val -> Val -> Val -> Val-ifz (Nm x) | x == 0 = const- | otherwise = ignore-ifz _ = ignore-ignore x y = y--------- Relational -------eq :: Val -> Val -> Fallible Val-eq (Nm a) (Nm b) = Right . mkInt $ if a == b then 1 else 0-eq _ _ = error "TODO eq"--neq :: Val -> Val -> Fallible Val-neq (Nm a) (Nm b) = Right . mkInt $ if a == b then 1 else 0-neq _ _ = error "TODO neq"--lt :: Val -> Val -> Fallible Val-lt (Nm a) (Nm b) = Right . mkInt $ if a < b then 1 else 0--lte :: Val -> Val -> Fallible Val-lte (Nm a) (Nm b) = Right . mkInt $ if a <= b then 1 else 0--gt :: Val -> Val -> Fallible Val-gt (Nm a) (Nm b) = Right . mkInt $ if a > b then 1 else 0--gte :: Val -> Val -> Fallible Val-gte (Nm a) (Nm b) = Right . mkInt $ if a >= b then 1 else 0--------- Arithmetic -------add :: Val -> Val -> Fallible Val-add (Nm a) (Nm b) = Right . Nm $ a + b-add _ _ = Left (error "TODO")--sub :: Val -> Val -> Fallible Val-sub (Nm a) (Nm b) = Right . Nm $ a - b-sub _ _ = Left (error "TODO")--mul :: Val -> Val -> Fallible Val-mul (Nm a) (Nm b) = Right . Nm $ a * b-mul _ _ = Left (error "TODO")--div :: Val -> Val -> Fallible Val-div (Nm a) (Nm b) = Right . Nm $ a / b-div _ _ = Left (error "TODO")----quo :: Val -> Val -> Maybe Val---quo = error "TODO"----rem :: Val -> Val -> Maybe Val---rem = error "TODO"----quorem :: Val -> Val -> Maybe Val---quorem = error "TODO"--------- Rationals -------numer :: Val -> Fallible Val-numer (Nm n) = Right . mkInt $ numerator n-numer _ = Left (error "TODO")--denom :: Val -> Fallible Val-denom (Nm n) = Right . mkInt $ denominator n-denom _ = Left (error "TODO")--trunc :: Val -> Fallible Val-trunc (Nm n) = Right . mkInt $ truncate n-trunc _ = Left (error "TODO")--numParts :: Val -> Fallible Val-numParts (Nm n) = let (whole, frac) = properFraction n- in Right $ mkSq [mkInt whole, Nm frac]-numParts _ = Left (error "TODO")--------- Floats --------------- Sequence/Text/Bytes -------len :: Val -> Fallible Val-len (Sq xs) = Right . mkInt $ Seq.length xs-len (Tx xs) = Right . mkInt $ T.length xs-len (By xs) = Right . mkInt $ BS.length xs-len _ = Left (error "TODO")--cat :: Val -> Val -> Fallible Val-cat (Sq xs) (Sq ys) = Right . Sq $ xs <> ys-cat (Tx xs) (Tx ys) = Right . Tx $ xs <> ys-cat (By xs) (By ys) = Right . By $ xs <> ys-cat _ _ = Left (error "TODO")--cut :: Val -> Val -> Fallible Val --FIXME I guess I really need to return (Either Val Val), where the left is an exception to raise-cut x (Nm q) = - case x of- Sq xs -> do- i <- n- when (i >= Seq.length xs) $ Left (error "TODO")- let (as, bs) = Seq.splitAt i xs- Right $ mkSq [Sq as, Sq bs]- Tx xs -> do- i <- n- when (i >= T.length xs) $ Left (error "TODO")- let (as, bs) = T.splitAt i xs- Right $ mkSq [Tx as, Tx bs]- By xs -> do- i <- n- when (i >= BS.length xs) $ Left (error "TODO")- let (as, bs) = BS.splitAt i xs- Right $ mkSq [By as, By bs]- where- n = if denominator q == 1 then Right (fromIntegral $ numerator q) else Left (error "TODO")--------- Xons -------{-| @get x f@ retrieves field @f@ from @x@, if the field exists. -}-get :: Val -> Val -> Fallible Val-get (Ob ob) (Sy sy) = maybe (Left (error "TODO")) Right $ Map.lookup sy ob-get _ _ = Left (error "TODO")--{-| Get a list of the fields in a value. -}-keys :: Val -> Fallible Val-keys (Ob ob) = Right . mkSq $ Sy <$> Map.keys ob-keys _ = Right $ mkSq []--{-| @extend a b@ extends and overwrites bindings in @b@ with bindings in @a@. -}-extend :: Val -> Val -> Val-extend (Ob ob') (Ob ob) = Ob $ Map.union ob' ob-extend _ (Ob ob) = (Ob ob)-extend (Ob ob') _ = Ob ob'-extend _ _ = mkOb []--{-| @delete x f@ removes field @f@ from @x@, if the field exists.- If it does not exist, then there is no change.--}-delete :: Val -> Val -> Fallible Val-delete (Ob ob) (Sy sy) = Right . Ob $ Map.delete sy ob-delete x _ = Right x---
− Octopus/Shortcut.hs
@@ -1,25 +0,0 @@-module Octopus.Shortcut where--import Import-import qualified Data.Sequence as Seq-import qualified Data.Map as Map--import Octopus.Data---mkInt :: Integral a => a -> Val-mkInt = Nm . fromIntegral--mkSy :: String -> Val-mkSy = Sy . intern--mkSq :: [Val] -> Val-mkSq = Sq . Seq.fromList--mkOb :: [(Symbol, Val)] -> Val-mkOb = Ob . Map.fromList---fromEnv :: Val -> Map Symbol Val-fromEnv (Ob ob) = ob-fromEnv _ = Map.empty
main.hs view
@@ -1,94 +1,69 @@+import Import import System.IO import System.Environment+import System.Console.GetOpt import System.Exit-import Control.Applicative import Control.Concurrent.MVar -import Octopus-import Octopus.Parser-import Octopus.Libraries- import qualified Data.Map as Map +import Language.Octopus+import Language.Octopus.Parser+import Language.Octopus.Libraries+import Language.Octopus.Primitive (resolveSymbol)+import Language.Octopus.Data.Shortcut (mkOb)++progVersion = "v0.0.1a" main :: IO () main = do- --parse_e <- parseOctopusFile "foo.oct" <$> readFile "test/foo.oct"- --case parse_e of- -- Left err -> print err- -- Right val -> do- -- print val- -- print =<< eval startData val- --exitSuccess-- test "do four: 4 ((vau x x) four);"- test "do four: 4 ((vau x (__eval__ x)) four);"- test "((vau [e, ast] e) dne)"- test "((vau [e, ast] ast) dne)"- test "(__extends__ [{a: 3}, {a: 2}, {a: 1}])"- test "((vau [e, ast] (__eval__ [__extends__ [{five: 5}, e], ast])) five)"- test "do four: 4 (vau [{}, ob] (__keys__ ob) {foo: 3, bar: four});"- test "do four: 4 ((vau [e, ob] (:x ob)) {x: four});"- test "do four: 4 ((vau [e, ob] (__eval__ [e, :x ob])) {x: four});"- test $ "do four: 4 (" ++ lambda ++ " ob (:x ob) {x: four});"- test $ "(" ++ lambda ++ " eight eight 8)"- test $ "("++letin++" eight 8 eight)"- - test $ "("++lambda++" let 2 "++letin++")"- test $ "("++lambda++" let (let x 2 x) "++letin++")"- test $ "("++lambda++" lambda 2 "++lambda++")"- test $ "("++lambda++" lambda (lambda x x 2) "++lambda++")"- test "(__let__ let __let__ (let x 3 x))"- test "(__let__ let __let__ (let x let (x y 3 y)))"- test "(__let__ let __let__ (let x let (x x 3 x)))"- test "(__lambda__ x x 7)"- test "(__lambda__ \955 (\955 x 7 \955) __lambda__)"- test "(__let__ \955 __lambda__ (\955 x (\955 x x) 2 7))"- test "((__lambda__ __\955__ ((__\955__ \955 ((\955 x x) 7)) __\955__)) __lambda__)"-- --TODO MAYBE this stuff could be the real definitions of let/lambda, but I've already got them built-in to the start environment (__let__ for good reason)- --test $ "("++lambda++" __\955__ (__\955__ \955 2) "++lambda++")"- --test $ "("++lambda++" __\955__ (__\955__ \955 2 __\955__) "++lambda++")"- --test $ "("++lambda++" __let__ (__let__ let __let__ 2) "++letin++")"- test $ "("++letin++" let "++letin++" (let x 2 x))"- test "[__lambda__ x x 3, __lambda__ y y 4]" --[3, 4]-- test "do \955: __lambda__\n x: 1 \n (\955 x x 3)\n y: 2\n [x, y];" --[1, 2]- test "(__del__ [{x: 1, y: 2}, `y])"- test "do \955: __lambda__\n\- \ delete: (\955 ob (vau [{}, field] (__del__ [ob, field])))\n\- \ (delete {x: 1, y: 2} x);"- test "do x: do \955: __lambda__\n\- \ (\955 y y 3);\n\- \ x;"- test "do defx: (__let__ x)\n\- \ (defx 5 x);"- test "do defx5: (__let__ x 5)\n\- \ (defx5 x);"- test "do [a, b, c]: [`there, `Bob, `hi] [c, a, b];"-- test "do x: (__add__ [1, 2])\n y: (__sub__ [1, 2])\n z: (__mul__ [2, 3])\n w: (__div__ [2, 3])\n [x, y, z, w];"- test "do [a, b]: (__cut__ [[1, 2, 3, 4, 5], 3])\n [a, b, __len__ a];"- test "do [a, b]: (__cut__ [\"hello\", 3])\n [a, b, __len__ a];"- test "do y: (__ifz!__ [0, `y, `n])\n n: (__ifz!__ [1, `y, `n])\n [y, n];"-- test "do {\955: \955}: (__import__ \"./test/foo.oct\") (\955 x x 6);"+ (opts, filepath) <- getOptions+ cache <- newMVar Map.empty+ parse_e <- parseOctopusFile filepath <$> readFile filepath+ case parse_e of+ Left err -> print err+ Right (_, val) -> do+ fileEnv <- eval cache initialEnv val+ case resolveSymbol (intern "main") fileEnv of+ Nothing -> return ()+ Just main -> print =<< eval cache fileEnv main+ exitSuccess -lambda = "(vau [{}, var] (vau [static, ast] (vau arg (__eval__ [__extends__ [__match__ [var, __eval__ arg], static], ast ]))))"-letin = "(vau [{}, x] (vau val (vau [e, body] (__eval__ [__extends__ [__match__ [x, __eval__ val], e], body]))))"-+data Options = Options { + } deriving (Show)+startOptions = Options { + } +getOptions :: IO (Options, FilePath)+getOptions = do+ (actions, args, errors) <- getOpt Permute options <$> getArgs+ if errors == []+ then case args of+ [] -> putErrLn "No file supplied." >> exitFailure+ [file] -> do+ opts <- foldl (>>=) (return startOptions) actions+ return (opts, file)+ _ -> putErrLn "Too many files supplied." >> exitFailure+ else mapM putErrLn errors >> exitFailure ---TODO---dot-infixing as normal---colon-infixing also desugars into a getter+options :: [OptDescr (Options -> IO Options)]+options =+ [ Option "V" ["version"]+ (NoArg+ (\_ -> do+ hPutStrLn stderr progVersion+ exitSuccess))+ "Print version"+ , Option "h" ["help"]+ (NoArg+ (\_ -> do+ prg <- getProgName+ putErrLn "Octopus interpreter."+ putErrLn "This program is lisenced under the GPLv3."+ putErrLn (usageInfo (prg ++ " [options] file") options)+ putErrLn "Interpret the given file of Octopus code."+ exitSuccess))+ "Show help"+ ] -testParse input = case parseOctopusExpr "" input of- Right val -> print val- Left err -> print err-test input = do- putStr $ input ++ " ===> "- cache <- newMVar Map.empty- case parseOctopusExpr "repl" input of- Right val -> print =<< eval cache startData val- Left err -> print err+putErrLn = hPutStrLn stderr
octopus.cabal view
@@ -2,8 +2,8 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: octopus-version: 0.0.1.0-synopsis: A 100-year language inspired by Kernel, JSON, Clojure, Arc and science.+version: 0.0.2.0+synopsis: Lisp with more dynamism, more power, more simplicity. description: Octopus is a highly dynamic programming language with an astounding (I think) power-to-weight ratio (expressivity-to-complexity). With just a handful of simple primitives, Octopus provides a complete programming environment. Its@@ -21,13 +21,14 @@ cabal-version: >=1.8 library- exposed-modules: Octopus,- Octopus.Data,- Octopus.Shortcut- Octopus.Parser,- Octopus.Basis,- Octopus.Primitive,- Octopus.Libraries+ exposed-modules: Language.Octopus,+ Language.Octopus.Data,+ Language.Octopus.Data.Shortcut+ Language.Octopus.Parser,+ Language.Octopus.Parser.Preprocess,+ Language.Octopus.Basis,+ Language.Octopus.Primitive,+ Language.Octopus.Libraries build-depends: base ==4.6.*, bytestring ==0.10.*, text ==0.11.*,@@ -36,9 +37,9 @@ symbol ==0.2.1, mtl ==2.1.*, parsec ==3.1.*,- hexpr ==0.0.0.0+ hexpr ==0.0.0.1 -executable octopus+executable octi main-is: main.hs -- other-modules: build-depends: base ==4.6.*,@@ -49,4 +50,4 @@ symbol ==0.2.1, mtl ==2.1.*, parsec ==3.1.*,- hexpr ==0.0.0.0+ hexpr ==0.0.0.1