{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Expression (load) where import Text.Parsec (sourceColumn, sourceLine, sourceName) import Atomo import Atomo.Parser (parseInput) import Atomo.Parser.Expand import Atomo.Pretty (pretty) import Atomo.Valuable load :: VM () load = do [p|`Block new: (es: List)|] =::: [e|`Block new: es arguments: []|] [p|`Block new: (es: List) arguments: (as: List)|] =: do es <- getList [e|es|] >>= mapM findExpression as <- getList [e|as|] >>= mapM (\e -> findExpression e >>= toPattern' . fromExpression) return (Expression (EBlock Nothing as (map fromExpression es))) [p|`List new: (es: List)|] =: do es <- getList [e|es|] >>= mapM findExpression return (Expression (EList Nothing (map fromExpression es))) [p|`Tuple new: (es: List)|] =: do es <- getList [e|es|] >>= mapM findExpression return (Expression (ETuple Nothing (map fromExpression es))) [p|`Match new: (branches: List) on: (value: Expression)|] =: do bs <- getList [e|branches|] let pats = map (fromExpression . head . fromTuple) bs exprs = map (fromExpression . (!! 1) . fromTuple) bs ps <- mapM toRolePattern' pats Expression value <- here "value" >>= findExpression return (Expression (EMatch Nothing value (zip ps exprs))) [p|`Set new: (pattern: Expression) to: (value: Expression)|] =: do Expression pat <- here "pattern" >>= findExpression Expression e <- here "value" >>= findExpression p <- toPattern' pat return (Expression $ ESet Nothing p e) [p|`Define new: (pattern: Expression) as: (expr: Expression)|] =: do Expression pat <- here "pattern" >>= findExpression Expression e <- here "expr" >>= findExpression p <- toDefinePattern' pat return (Expression $ EDefine Nothing p e) [p|`Dispatch new: (name: Particle) to: (targets: List) &optionals: []|] =: do Particle name <- here "name" >>= findParticle ts <- getList [e|targets|] >>= mapM findExpression os <- getList [e|optionals|] >>= mapM fromValue let opts = map (\(Particle (Single { mName = n }), Expression e) -> option n e) os case name of Single { mName = n } -> return $ Expression (EDispatch Nothing (single' n (fromExpression (head ts)) opts)) Keyword { mNames = ns } -> return $ Expression (EDispatch Nothing (keyword' ns (map fromExpression ts) opts)) [p|`DefineDynamic new: (name: Expression) as: (root: Expression)|] =: do n <- here "name" >>= findExpression >>= toName . fromExpression Expression r <- here "root" >>= findExpression return . Expression $ EDefineDynamic Nothing n r [p|`SetDynamic new: (name: Expression) to: (root: Expression)|] =: do n <- here "name" >>= findExpression >>= toName . fromExpression Expression r <- here "root" >>= findExpression return . Expression $ ESetDynamic Nothing n r [p|`GetDynamic new: (name: Expression)|] =: do n <- here "name" >>= findExpression >>= toName . fromExpression return . Expression $ EGetDynamic Nothing n [p|`NewDynamic new: (bindings: List) do: (expr: Expression)|] =: do ns <- getList [e|bindings map: @from|] >>= mapM findExpression >>= mapM (toName . fromExpression) exprs <- liftM (map fromExpression) $ getList [e|bindings map: @to|] >>= mapM findExpression Expression e <- here "expr" >>= findExpression return . Expression $ ENewDynamic Nothing (zip ns exprs) e [p|(s: String) parse-expressions|] =: getString [e|s|] >>= liftM (list . map Expression) . parseInput [p|top evaluate: (e: Expression)|] =: do t <- here "top" Expression e <- here "e" >>= findExpression withTop t (eval e) [p|(e: Expression) expand|] =: do Expression e <- here "e" >>= findExpression liftM Expression $ macroExpand e [p|(e: Expression) pretty-expression|] =: do Expression e <- here "e" >>= findExpression toValue (pretty e) [p|(e: Expression) location|] =: do Expression e <- here "e" >>= findExpression case eLocation e of Nothing -> return (particle "none") Just s -> return $ keyParticleN ["name", "line", "column"] [ string (sourceName s) , Integer (fromIntegral (sourceLine s)) , Integer (fromIntegral (sourceColumn s)) ] [p|(e: Expression) type|] =: do Expression e <- here "e" >>= findExpression case e of EDispatch { eMessage = Keyword {} } -> return (keyParticleN ["dispatch"] [particle "keyword"]) EDispatch { eMessage = Single {} } -> return (keyParticleN ["dispatch"] [particle "single"]) EDefine {} -> return (particle "define") ESet {} -> return (particle "set") EOperator {} -> return (particle "operator") EPrimitive {} -> return (particle "primitive") EBlock {} -> return (particle "block") EVM {} -> return (particle "vm") EList {} -> return (particle "list") ETuple {} -> return (particle "tuple") EMacro {} -> return (particle "macro") EForMacro {} -> return (particle "for-macro") ETop {} -> return (particle "top") EQuote {} -> return (particle "quote") EUnquote {} -> return (particle "unquote") EParticle { eParticle = Keyword {} } -> return (keyParticleN ["particle"] [particle "keyword"]) EParticle { eParticle = Single {} } -> return (keyParticleN ["particle"] [particle "single"]) ENewDynamic {} -> return (particle "new-dynamic") ESetDynamic {} -> return (particle "set-dynamic") EDefineDynamic {} -> return (particle "define-dynamic") EGetDynamic {} -> return (particle "get-dynamic") EMacroQuote {} -> return (particle "macro-quote") EMatch {} -> return (particle "match") [p|(e: Expression) target|] =: do Expression e <- here "e" >>= findExpression case e of EDispatch { eMessage = Single { mTarget = t } } -> return (Expression t) EMatch { eTarget = t } -> return (Expression t) _ -> raise ["no-target-for"] [Expression e] [p|(e: Expression) targets|] =: do Expression e <- here "e" >>= findExpression case e of EDispatch { eMessage = Keyword { mTargets = ts } } -> return (list (map Expression ts)) EDispatch { eMessage = Single { mTarget = t } } -> return $ list [Expression t] _ -> raise ["no-targets-for"] [Expression e] [p|(e: Expression) optionals|] =: do Expression e <- here "e" >>= findExpression case e of EDispatch { eMessage = m } -> liftM list $ mapM (\(Option _ n v) -> toValue (particle n, Expression v)) (mOptionals m) _ -> raise ["no-optionals-for"] [Expression e] [p|(e: Expression) name|] =: do Expression e <- here "e" >>= findExpression case e of EParticle _ (Single { mName = n }) -> return (string n) EDispatch { eMessage = Single { mName = n } } -> return (string n) EMacroQuote { eName = n } -> return (string n) _ -> raise ["no-name-for"] [Expression e] [p|(e: Expression) names|] =: do Expression e <- here "e" >>= findExpression case e of EParticle _ (Keyword { mNames = ns }) -> return (list (map string ns)) EDispatch { eMessage = Keyword { mNames = ns } } -> return (list (map string ns)) _ -> raise ["no-names-for"] [Expression e] [p|(e: Expression) particle|] =: do Expression e <- here "e" >>= findExpression case e of EDispatch { eMessage = Keyword { mNames = ns } } -> return (keyParticle ns (replicate (fromIntegral $ length ns + 1) Nothing)) EDispatch { eMessage = Single { mName = n } } -> return (particle n) _ -> raise ["no-particle-for"] [Expression e] [p|(e: Expression) values|] =: do Expression e <- here "e" >>= findExpression case e of EParticle { eParticle = Keyword { mTargets = mes } } -> return . list $ map (maybe (particle "none") (keyParticleN ["ok"] . (:[]) . Expression)) mes _ -> raise ["no-values-for"] [Expression e] [p|(e: Expression) contents|] =: do Expression e <- here "e" >>= findExpression case e of EBlock { eContents = es } -> return (list (map Expression es)) EList { eContents = es } -> return (list (map Expression es)) ETuple { eContents = es } -> return (list (map Expression es)) EMacroQuote { eRaw = r } -> return (string r) EMatch { eBranches = bs } -> liftM list (mapM toValue bs) _ -> raise ["no-contents-for"] [Expression e] [p|(e: Expression) flags|] =: do Expression e <- here "e" >>= findExpression case e of EMacroQuote { eFlags = fs } -> return (list (map Character fs)) _ -> raise ["no-flags-for"] [Expression e] [p|(e: Expression) arguments|] =: do Expression e <- here "e" >>= findExpression case e of EBlock { eArguments = as } -> return (list (map Pattern as)) _ -> raise ["no-arguments-for"] [Expression e] [p|(e: Expression) pattern|] =: do Expression e <- here "e" >>= findExpression case e of ESet { ePattern = p } -> return (Pattern p) EDefine { emPattern = p } -> return (Pattern (PMessage p)) EMacro { emPattern = p } -> return (Pattern (PMessage p)) _ -> raise ["no-pattern-for"] [Expression e] [p|(e: Expression) expression|] =: do Expression e <- here "e" >>= findExpression case e of ESet { eExpr = e } -> return (Expression e) EDefine { eExpr = e } -> return (Expression e) EMacro { eExpr = e } -> return (Expression e) EForMacro { eExpr = e } -> return (Expression e) EQuote { eExpr = e } -> return (Expression e) EUnquote { eExpr = e } -> return (Expression e) _ -> raise ["no-expression-for"] [Expression e] [p|(e: Expression) associativity|] =: do Expression e <- here "e" >>= findExpression case e of EOperator { eAssoc = ALeft } -> return (particle "left") EOperator { eAssoc = ARight } -> return (particle "right") _ -> raise ["no-associativity-for"] [Expression e] [p|(e: Expression) precedence|] =: do Expression e <- here "e" >>= findExpression case e of EOperator { ePrec = p } -> return (Integer p) _ -> raise ["no-precedence-for"] [Expression e] [p|(e: Expression) operators|] =: do Expression e <- here "e" >>= findExpression case e of EOperator { eNames = ns } -> return (list (map (\n -> keyParticle [n] [Nothing, Nothing]) ns)) _ -> raise ["no-operators-for"] [Expression e] toName :: Expr -> VM String toName (EDispatch { eMessage = Single { mName = n } }) = return n toName x = raise ["unknown-dynamic-name"] [Expression x]