diff --git a/Language/Octopus.hs b/Language/Octopus.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus.hs @@ -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 "#") "* → *" 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 + + diff --git a/Language/Octopus/Basis.hs b/Language/Octopus/Basis.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Basis.hs @@ -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 + + + + + + + + + + diff --git a/Language/Octopus/Data.hs b/Language/Octopus/Data.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Data.hs @@ -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 _) = "#" --TODO at least show some metadata + show (Sy sy) = show sy + show (Tg i spelling) = "#" + show (Ab tag 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) = "#" + show (Ce x) = "" --TODO show contents + show (Ar xs) = "#" --TODO show contents + --show (Eh tag fn) = "#" + show (Pr f) = "#<" ++ show f ++ ">" diff --git a/Language/Octopus/Data/Shortcut.hs b/Language/Octopus/Data/Shortcut.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Data/Shortcut.hs @@ -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 diff --git a/Language/Octopus/Libraries.hs b/Language/Octopus/Libraries.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Libraries.hs @@ -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 []) + + diff --git a/Language/Octopus/Parser.hs b/Language/Octopus/Parser.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Parser.hs @@ -0,0 +1,339 @@ +{-| Parse Octopus source code. The Octopus grammar is: + + +> file ::= ('export' )? * +> stmt ::= | _field_ | 'open' +> expr ::= | | +> | | | +> | | +> | '(' ')' | /\./ +> +> atom ::= _symbol_ | _number_ | _string_ | _heredoc_ | _primitive_ +> list ::= '[' (+ (',' +)*)? ']' +> object ::= '{' (_field_ + (',' _field_ +)*)? '}' +> combination ::= '(' + ')' +> block ::= 'do' + ';' +> accessor ::= /@/ | /:/ +> mutator ::= '@(' _field_ + ')' | ':(' _field_ + ')' +> quotation ::= /`/ +> +> symbol ::= _name_ - reserved +> reserved = {'do', 'letrec', 'export', 'open'} +> primitive ::= /#<[a-zA-Z]+>/ +> field ::= /:/ +> number ::= /[+-]?(0[xX]|0[oO]|0[bB]|)/ +> decnum ::= /\d+(\.\d+?|\/\d+)?/ +> hexnum ::= /\x+(\.\x+([hH][+-]?\x+)?|\/\x+)?/ +> octnum ::= /[0-7]+(\.[0-7]+?|\/[0-7]+)?/ +> binnum ::= /[01]+(\.[01]+?|\/[01]+)?/ +> exponent ::= /[eE][+-]?\d+|[hH][+-]?\x+/ +> string ::= /"([^"\\]|\\[abefntv'"&\\]|\\|\\\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 = /[^#\\"`()[]{}@:;.,0-9-]/ +> nametail = /[^#\\"`()[]{}@:;.,]*/ +> +> linecomment ::= /#(?!<)\.*?\n/ +> 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 + + + diff --git a/Language/Octopus/Parser/Preprocess.hs b/Language/Octopus/Parser/Preprocess.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Parser/Preprocess.hs @@ -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 "#!" diff --git a/Language/Octopus/Primitive.hs b/Language/Octopus/Primitive.hs new file mode 100644 --- /dev/null +++ b/Language/Octopus/Primitive.hs @@ -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 + + + + diff --git a/Octopus.hs b/Octopus.hs deleted file mode 100644 --- a/Octopus.hs +++ /dev/null @@ -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" - - diff --git a/Octopus/Basis.hs b/Octopus/Basis.hs deleted file mode 100644 --- a/Octopus/Basis.hs +++ /dev/null @@ -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 - - - - - - - - - - diff --git a/Octopus/Data.hs b/Octopus/Data.hs deleted file mode 100644 --- a/Octopus/Data.hs +++ /dev/null @@ -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 _) = "" --TODO at least show some metadata - show (Sy sy) = show sy - show (Tg i) = "" - show (Ab tag 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) = "" - show (Ce x) = "" --TODO show contents - show (Ar xs) = "" --TODO show contents - show (Pr f) = "<" ++ show f ++ ">" diff --git a/Octopus/Libraries.hs b/Octopus/Libraries.hs deleted file mode 100644 --- a/Octopus/Libraries.hs +++ /dev/null @@ -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 []) diff --git a/Octopus/Parser.hs b/Octopus/Parser.hs deleted file mode 100644 --- a/Octopus/Parser.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-| Parse Octopus source code. The Octopus grammar is: - -@ -file ::= (\ | \)* -defn ::= _field_ \ -expr ::= \ | \ | \ - | \ | \ | \ - | '(' \ ')' - -atom ::= _symbol_ | _number_ | _string_ | _heredoc_ | _accessor_ -list ::= '[' (\+ (',' \+)*)? ']' -object ::= '{' (_field_ \+ (',' _field_ \+)*)? '}' -combination ::= '(' \ \+ ')' -block ::= 'do' (\ | \)+ ';' -quotation ::= '`' \ - -symbol ::= \/\\/ - reserved - reserved = {'do'} -field ::= \/\:\/ -accessor ::= \/:\\/ -number ::= \/[+-]?(0[xX]\|0[oO]\|0[bB]\|\)\/ - decnum ::= \/\\d+(\\.\\d+\?|\\\/\\d+)?\/ - hexnum ::= \/\\x+(\\.\\x+([hH][+-]?\\x+)?|\\\/\\x+)?\/ - octnum ::= \/[0-7]+(\\.[0-7]+\?|\\\/[0-7]+)?\/ - binnum ::= \/[01]+(\\.[01]+\?|\\\/[01]+)?\/ - exponent ::= \/[eE][+-]?\\d+|[hH][+-]?\\x+\/ -string ::= \/\"([^\\\\\"]|\\\\[abefntv\'\"\\\\&]|\\\\\|\\\\\\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 ::= \/\\|-(\|-)\|-\/ - nametail = \/[^\#\\\\\"`()[]{}:;.,]*\/ - namehead = \/[^\#\\\\\"`()[]{}:;.,0-9-]\/ - -linecomment ::= \/#(?!\>\>)\\.*?\\n\/ -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 - - - diff --git a/Octopus/Primitive.hs b/Octopus/Primitive.hs deleted file mode 100644 --- a/Octopus/Primitive.hs +++ /dev/null @@ -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 - - - diff --git a/Octopus/Shortcut.hs b/Octopus/Shortcut.hs deleted file mode 100644 --- a/Octopus/Shortcut.hs +++ /dev/null @@ -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 diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -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 diff --git a/octopus.cabal b/octopus.cabal --- a/octopus.cabal +++ b/octopus.cabal @@ -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