Commits

Alex Suraci  committed 77ae018

fleshed out Atomo.Types

  • Participants
  • Parent commits e1b26f9

Comments (0)

Files changed (1)

File src/Atomy/Types.hs

-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}
+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeSynonymInstances #-}
 module Atomy.Types where
 
 import Control.Concurrent (ThreadId)
 import Control.Monad.State
 import Data.Dynamic
 import Data.Hashable
+import Data.List (nub)
 import Text.Parsec (ParseError, SourcePos)
 import Text.PrettyPrint (Doc)
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Vector as V
+import qualified Language.Haskell.Interpreter as H
+import qualified Language.Haskell.TH.Syntax as S
 
 
--- | The Atomo VM. A Continuation monad wrapping a State monad.
+-- | The Atomy VM. A Continuation monad wrapping a State monad.
 type VM = ContT Value (StateT Env IO)
 
--- | All values usable in Atomo.
+-- | All values usable in Atomy.
 data Value
     -- | A block of expressions, bound to a context and with optional arguments.
-    = Block !Value [Pattern] [Expr]
+    = Block !Trait [Pattern] [Expr]
 
     -- | A boolean value.
     | Boolean { fromBoolean :: !Bool }
     -- | A method value.
     | Method { fromMethod :: Method }
 
-    {-| A particle value.-}
+    -- | A particle value.
     | Particle { fromParticle :: Particle Value }
 
     -- | A process; a communications channel and the thread's ID.
 
 data Env =
     Env
-        { top :: Value
-        , clock :: Int
+        -- | Current unique identifier.
+        { clock :: Int
+
+        -- | The current toplevel value.
+        , top :: Value
+
+        -- | Primitive value traits.
         , primitives :: IDs
+
+        -- | Methods in-scope.
         , methods :: Methods
 
-          -- | The parser's state, passed around when a parser action needs to
-          -- be run.
+        -- | The parser's state, passed around when a parser action needs to be
+        -- run.
         , parserState :: ParserState
 
-          -- | This process's communications channel.
+        -- | This process's communications channel.
         , channel :: Channel
+
+        -- | Function to call which will shut down the entire VM when called
+        -- from any thread.
+        , halt :: Halt
+
+        -- | Paths to search for files.
+        , loadPath :: [FilePath]
+
+        -- | Files aready loaded.
+        , loaded :: [FilePath]
+
+        -- | The last N expressions evaluated up to the current error.
+        , stack :: [Expr]
+
+        -- | The current dynamic environment.
+        , dynamic :: DynamicMap
+
+        -- | Unwind actions for call/cc etc.
+        , unwinds :: [(Value, Value)]
         }
     deriving Show
 
     deriving (Show, Typeable)
 
 -- | Shortcut error values.
-data AtomoError
+data AtomyError
     = Error Value
     | ParseError ParseError
     | DidNotUnderstand (Message Value)
     | Mismatch Pattern Value
-    {-| ImportError H.InterpreterError-}
+    | ImportError H.InterpreterError
     | FileNotFound String
     | ParticleArity Int Int
     | BlockArity Int Int
 -- | A reference to a continuation function.
 type Continuation = Value -> VM Value
 
+-- | A dynamic environment
+type DynamicMap = IM.IntMap [Value]
+
+-- | IO action called to halt the environment.
+type Halt = IO ()
+
 
 instance Eq Value where
     (==) (Block at aps aes) (Block bt bps bes) =
     (==) (EVM {}) (EVM {}) = False
     (==) _ _ = False
 
-
 instance Show Channel where
     show _ = "Channel"
 
 instance Show Continuation where
     show _ = "Continuation"
 
+instance Show Halt where
+    show _ = "Halt"
+
 instance Show (VM a) where
     show _ = "VM"
 
+instance Typeable (VM a) where
+    typeOf _ = mkTyConApp (mkTyCon "VM") [typeOf ()]
+
 
 -- | Evaluate x with e as the environment.
 runWith :: VM Value -> Env -> IO Value
 -- | Initial "empty" environment state.
 startEnv :: Env
 startEnv = Env
-    { top = error "top object not set"
+    { clock = 1
+    , methods = Bottom
+    , top = error "top object not set"
     , primitives =
         IDs
             { idObject = error "idObject not set"
             , idString = error "idString not set"
             }
     , channel = error "channel not set"
-    {-, halt = error "halt not set"-}
-    {-, loadPath = []-}
-    {-, loaded = []-}
-    {-, stack = []-}
+    , halt = error "halt not set"
+    , loadPath = []
+    , loaded = []
+    , stack = []
     , parserState = startParserState
-    {-, dynamic = M.empty-}
-    {-, unwinds = []-}
-    , clock = 1
-    , methods = Bottom
+    , dynamic = IM.empty
+    , unwinds = []
     }
 
 
 {-# INLINE pkeyword #-}
 pkeyword ns = PMessage . keyword ns
 
--- | Convert an AtomoError into the Value we want to error with.
-asValue :: AtomoError -> Value
+-- | Is a value a `Block'?
+isBlock :: Value -> Bool
+isBlock (Block _ _ _) = True
+isBlock _ = False
+
+-- | Is a value a `Boolean'?
+isBoolean :: Value -> Bool
+isBoolean (Boolean _) = True
+isBoolean _ = False
+
+-- | Is a value a `Char'?
+isChar :: Value -> Bool
+isChar (Char _) = True
+isChar _ = False
+
+-- | Is a value a `Continuation'?
+isContinuation :: Value -> Bool
+isContinuation (Continuation _) = True
+isContinuation _ = False
+
+-- | Is a value a `Double'?
+isDouble :: Value -> Bool
+isDouble (Double _) = True
+isDouble _ = False
+
+-- | Is a value an `Expression'?
+isExpression :: Value -> Bool
+isExpression (Expression _) = True
+isExpression _ = False
+
+-- | Is a value a `Haskell'?
+isHaskell :: Value -> Bool
+isHaskell (Haskell _) = True
+isHaskell _ = False
+
+-- | Is a value an `Integer'?
+isInteger :: Value -> Bool
+isInteger (Integer _) = True
+isInteger _ = False
+
+-- | Is a value a `List'?
+isList :: Value -> Bool
+isList (List _) = True
+isList _ = False
+
+-- | Is a value a `Message'?
+isMessage :: Value -> Bool
+isMessage (Message _) = True
+isMessage _ = False
+
+-- | Is a value a `Method'?
+isMethod :: Value -> Bool
+isMethod (Method _) = True
+isMethod _ = False
+
+-- | Is a value a `Particle'?
+isParticle :: Value -> Bool
+isParticle (Particle _) = True
+isParticle _ = False
+
+-- | Is a value a `Pattern'?
+isPattern :: Value -> Bool
+isPattern (Pattern _) = True
+isPattern _ = False
+
+-- | Is a value a `Process'?
+isProcess :: Value -> Bool
+isProcess (Process _ _) = True
+isProcess _ = False
+
+-- | Is a value a `Rational'?
+isRational :: Value -> Bool
+isRational (Rational _) = True
+isRational _ = False
+
+-- | Is a value a `String'?
+isString :: Value -> Bool
+isString (String _) = True
+isString _ = False
+
+-- | Is a value a `Trait'?
+isTrait :: Value -> Bool
+isTrait (Trait _) = True
+isTrait _ = False
+
+-- | Convert an AtomyError into the Value we want to error with.
+asValue :: AtomyError -> Value
 asValue (Error v) = v
 asValue (ParseError pe) =
     keyParticleN ["parse-error"] [string (show pe)]
     keyParticleN
         ["pattern", "did-not-match"]
         [Pattern pat, v]
-{-asValue (ImportError (H.UnknownError s)) =-}
-    {-keyParticleN ["unknown-hint-error"] [string s]-}
-{-asValue (ImportError (H.WontCompile ges)) =-}
-    {-keyParticleN ["wont-compile"] [list (nub $ map (string . H.errMsg) ges)]-}
-{-asValue (ImportError (H.NotAllowed s)) =-}
-    {-keyParticleN ["not-allowed"] [string s]-}
-{-asValue (ImportError (H.GhcException s)) =-}
-    {-keyParticleN ["ghc-exception"] [string s]-}
+asValue (ImportError (H.UnknownError s)) =
+    keyParticleN ["unknown-hint-error"] [string s]
+asValue (ImportError (H.WontCompile ges)) =
+    keyParticleN ["wont-compile"] [list (nub $ map (string . H.errMsg) ges)]
+asValue (ImportError (H.NotAllowed s)) =
+    keyParticleN ["not-allowed"] [string s]
+asValue (ImportError (H.GhcException s)) =
+    keyParticleN ["ghc-exception"] [string s]
 asValue (FileNotFound fn) =
     keyParticleN ["file-not-found"] [string fn]
 asValue (ParticleArity e' g) =
     traitMatch xx yx && traitMatch xy yy
 
 unary :: Int -> Trait
-unary n = Unary n n
+unary = Unary
 
 union :: Trait -> Trait -> Trait
-union x y = Union (tHash x * 0xdeadbeef + tHash y) x y
+union = Union
 
 intersection :: Trait -> Trait -> Trait
-intersection x y = Intersection (tHash x * 0xbeefdead + tHash y) x y
+intersection = Intersection
 
 derives :: Trait -> Trait -> Bool
 derives x@(Unary _) (Union _ y) =
 derives (Union xx xy) (Union _ y) =
     xx `derives` y || xy `derives` y
 derives _ _ = False
+
+
+-- QuasiQuoter stuff
+instance S.Lift Expr where
+    lift (Define _ p e) = [| Define Nothing p e |]
+    lift (Set _ p e) = [| Set Nothing p e |]
+    lift (Dispatch _ m) = [| Dispatch Nothing m |]
+    lift (Operator _ ns a p) = [| Operator Nothing ns a p |]
+    lift (Primitive _ v) = [| Primitive Nothing v |]
+    lift (EBlock _ as es) = [| EBlock Nothing as es |]
+    lift (EVM {}) = error "cannot lift EVM"
+    lift (EList _ es) = [| EList Nothing es |]
+    lift (ETop _) = [| ETop Nothing |]
+    lift (EParticle _ p) = [| EParticle Nothing p |]
+    lift (EMacro _ p e) = [| EMacro Nothing p e |]
+    lift (EForMacro _ e) = [| EForMacro Nothing e |]
+    lift (EQuote _ e) = [| EQuote Nothing e |]
+    lift (EUnquote _ e) = [| EUnquote Nothing e |]
+    lift (ENewDynamic _ bs e) = [| ENewDynamic Nothing bs e |]
+    lift (ESetDynamic _ n e) = [| ESetDynamic Nothing n e |]
+    lift (EDefineDynamic _ n e) = [| EDefineDynamic Nothing n e |]
+    lift (EGetDynamic _ n) = [| EGetDynamic Nothing n |]
+
+instance S.Lift Assoc where
+    lift ALeft = [| ALeft |]
+    lift ARight = [| ARight |]
+
+instance (S.Lift v) => S.Lift (Message v) where
+    lift (Keyword i ns vs) = [| Keyword i ns vs |]
+    lift (Single i n v) = [| Single i n v |]
+
+instance S.Lift Value where
+    lift (Block s as es) = [| Block s as es |]
+    lift (Boolean b) = [| Boolean b |]
+    lift (Char c) = [| Char c |]
+    lift (Double d) = [| Double $(return $ S.LitE (S.RationalL (toRational d))) |]
+    lift (Expression e) = [| Expression e |]
+    lift (Integer i) = [| Integer i |]
+    lift (Message m) = [| Message m |]
+    lift (Particle p) = [| Particle p |]
+    lift (Pattern p) = [| Pattern p |]
+    lift (String s) = [| String (T.pack $(return $ S.LitE (S.StringL (T.unpack s)))) |]
+    lift v = error $ "no lift for: " ++ show v
+
+instance S.Lift Pattern where
+    lift PAny = [| PAny |]
+    lift (PHeadTail h t) = [| PHeadTail h t |]
+    lift (PMessage m) = [| PMessage m |]
+    lift (PList ps) = [| PList ps |]
+    lift (PMatch v) = [| PMatch v |]
+    lift (PNamed n p) = [| PNamed n p |]
+    lift (PObject e) = [| PObject e |]
+    lift PEDispatch = [| PEDispatch |]
+    lift PEOperator = [| PEOperator |]
+    lift PEPrimitive = [| PEPrimitive |]
+    lift PEBlock = [| PEBlock |]
+    lift PEList = [| PEList |]
+    lift PEMacro = [| PEMacro |]
+    lift PEParticle = [| PEParticle |]
+    lift PETop = [| PETop |]
+    lift PEQuote = [| PEQuote |]
+    lift PEUnquote = [| PEUnquote |]
+    lift (PExpr e) = [| PExpr e |]
+    lift (PInstance p) = [| PInstance p |]
+    lift (PStrict p) = [| PStrict p |]
+
+instance S.Lift Trait where
+    lift (Unary n) = [| Unary n |]
+    lift (Union x y) = [| Union x y |]
+    lift (Intersection x y) = [| Intersection x y |]