{-# LANGUAGE BangPatterns, DeriveDataTypeable, TypeSynonymInstances #-} module Atomo.Types where import Control.Concurrent (ThreadId) import Control.Concurrent.Chan import "monads-fd" Control.Monad.Cont import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import Data.Dynamic import Data.Hashable (hash) import Data.IORef import Data.Typeable import Text.Parsec (ParseError, SourcePos) import qualified Data.IntMap as M import qualified Data.Text as T import qualified Data.Vector as V import qualified Language.Haskell.Interpreter as H type VM = ErrorT AtomoError (ContT (Either AtomoError Value) (StateT Env IO)) data Value = Block !Value [Pattern] [Expr] | Boolean { fromBoolean :: {-# UNPACK #-} !Bool } | Char { fromChar :: {-# UNPACK #-} !Char } | Continuation { fromContinuation :: Continuation } | Double { fromDouble :: {-# UNPACK #-} !Double } | Expression { fromExpression :: Expr } | Haskell Dynamic | Integer { fromInteger :: !Integer } | List VVector | Message { fromMessage :: Message } | Method { fromMethod :: Method } | Particle { fromParticle :: Particle } | Process Channel ThreadId | Pattern { fromPattern :: Pattern } | Rational Rational | Reference { rORef :: {-# UNPACK #-} !ORef } | String { fromString :: !T.Text } deriving (Show, Typeable) data Object = Object { oDelegates :: !Delegates , oMethods :: !(MethodMap, MethodMap) -- singles, keywords } deriving (Show, Typeable) data Method = Responder { mPattern :: !Pattern , mContext :: !Value , mExpr :: !Expr } | Macro { mPattern :: !Pattern , mExpr :: !Expr } | Slot { mPattern :: !Pattern , mValue :: !Value } deriving (Eq, Show, Typeable) data Message = Keyword { mID :: !Int , mNames :: [String] , mTargets :: [Value] } | Single { mID :: !Int , mName :: String , mTarget :: Value } deriving (Eq, Show, Typeable) data Particle = PMSingle String | PMKeyword [String] [Maybe Value] deriving (Eq, Show, Typeable) data AtomoError = Error Value | ParseError ParseError | DidNotUnderstand Message | Mismatch Pattern Value | ImportError H.InterpreterError | FileNotFound String | ParticleArity Int Int | BlockArity Int Int | NoExpressions | ValueNotFound String Value | DynamicNeeded String deriving (Show, Typeable) -- pattern-matches data Pattern = PAny | PHeadTail Pattern Pattern | PKeyword { ppID :: !Int , ppNames :: [String] , ppTargets :: [Pattern] } | PList [Pattern] | PMatch Value | PNamed String Pattern | PObject Expr | PPMKeyword [String] [Pattern] | PSingle { ppID :: !Int , ppName :: String , ppTarget :: Pattern } | PThis -- expression types, used in macros | PEDefine | PESet | PEDispatch | PEOperator | PEPrimitive | PEBlock | PEList | PEMacro | PEParticle | PETop | PEQuote | PEUnquote deriving (Show, Typeable) -- expressions data Expr = Define { eLocation :: Maybe SourcePos , ePattern :: Pattern , eExpr :: Expr } | Set { eLocation :: Maybe SourcePos , ePattern :: Pattern , eExpr :: Expr } | Dispatch { eLocation :: Maybe SourcePos , eMessage :: EMessage } | Operator { eLocation :: Maybe SourcePos , eNames :: [String] , eAssoc :: Assoc , ePrec :: Integer } | Primitive { eLocation :: Maybe SourcePos , eValue :: !Value } | EBlock { eLocation :: Maybe SourcePos , eArguments :: [Pattern] , eContents :: [Expr] } | EList { eLocation :: Maybe SourcePos , eContents :: [Expr] } | EMacro { eLocation :: Maybe SourcePos , ePattern :: Pattern , eExpr :: Expr } | EParticle { eLocation :: Maybe SourcePos , eParticle :: EParticle } | ETop { eLocation :: Maybe SourcePos } | EVM { eLocation :: Maybe SourcePos , eAction :: VM Value } | EQuote { eLocation :: Maybe SourcePos , eExpr :: Expr } | EUnquote { eLocation :: Maybe SourcePos , eExpr :: Expr } deriving (Show, Typeable) data EMessage = EKeyword { emID :: !Int , emNames :: [String] , emTargets :: [Expr] } | ESingle { emID :: !Int , emName :: String , emTarget :: Expr } deriving (Eq, Show, Typeable) data EParticle = EPMSingle String | EPMKeyword [String] [Maybe Expr] deriving (Eq, Show, Typeable) -- the evaluation environment data Env = Env { top :: Value , primitives :: IDs , channel :: Channel , halt :: IO () , loadPath :: [FilePath] , loaded :: [FilePath] , stack :: [Expr] , parserState :: ParserState } deriving Typeable -- operator associativity data Assoc = ALeft | ARight deriving (Eq, Show, Typeable) -- a giant record of the objects for each primitive value data IDs = IDs { idMatch :: ORef -- used in dispatch to refer to the object currently being searched , idObject :: ORef -- root object , idBlock :: ORef , idBoolean :: ORef , idChar :: ORef , idContinuation :: ORef , idDouble :: ORef , idExpression :: ORef , idHaskell :: ORef , idInteger :: ORef , idList :: ORef , idMessage :: ORef , idMethod :: ORef , idParticle :: ORef , idProcess :: ORef , idPattern :: ORef , idRational :: ORef , idString :: ORef } deriving (Show, Typeable) data ParserState = ParserState { psOperators :: Operators , psMacros :: (MethodMap, MethodMap) } deriving (Show, Typeable) startParserState :: ParserState startParserState = ParserState [] (M.empty, M.empty) -- helper synonyms type Operators = [(String, (Assoc, Integer))] -- name -> assoc, precedence type Delegates = [Value] type Channel = Chan Value type MethodMap = M.IntMap [Method] type ORef = IORef Object type VVector = V.Vector Value type Continuation = IORef (Value -> VM Value) -- a basic Eq instance instance Eq Value where (==) (Block at aps aes) (Block bt bps bes) = at == bt && aps == bps && aes == bes (==) (Boolean a) (Boolean b) = a == b (==) (Char a) (Char b) = a == b (==) (Continuation a) (Continuation b) = a == b (==) (Double a) (Double b) = a == b (==) (Expression a) (Expression b) = a == b (==) (Haskell _) (Haskell _) = False (==) (Integer a) (Integer b) = a == b (==) (List a) (List b) = a == b (==) (Message a) (Message b) = a == b (==) (Method a) (Method b) = a == b (==) (Particle a) (Particle b) = a == b (==) (Process _ a) (Process _ b) = a == b (==) (Rational a) (Rational b) = a == b (==) (Reference a) (Reference b) = a == b (==) (String a) (String b) = a == b (==) _ _ = False instance Eq Pattern where -- check if two patterns are "equivalent", ignoring names for patterns -- and other things that mean the same thing (==) PAny PAny = True (==) (PHeadTail ah at) (PHeadTail bh bt) = (==) ah bh && (==) at bt (==) (PKeyword _ ans aps) (PKeyword _ bns bps) = ans == bns && and (zipWith (==) aps bps) (==) (PList aps) (PList bps) = length aps == length bps && and (zipWith (==) aps bps) (==) (PMatch a) (PMatch b) = a == b (==) (PNamed _ a) (PNamed _ b) = (==) a b (==) (PNamed _ a) b = (==) a b (==) a (PNamed _ b) = (==) a b (==) (PPMKeyword ans aps) (PPMKeyword bns bps) = ans == bns && and (zipWith (==) aps bps) (==) (PSingle ai _ at) (PSingle bi _ bt) = ai == bi && (==) at bt (==) PThis PThis = True (==) _ _ = False instance Eq Expr where (==) (Define _ ap' ae) (Define _ bp be) = ap' == bp && ae == be (==) (Set _ ap' ae) (Set _ bp be) = ap' == bp && ae == be (==) (Dispatch _ am) (Dispatch _ bm) = am == bm (==) (Operator _ ans aa ap') (Operator _ bns ba bp) = ans == bns && aa == ba && ap' == bp (==) (Primitive _ a) (Primitive _ b) = a == b (==) (EBlock _ aas aes) (EBlock _ bas bes) = aas == bas && aes == bes (==) (EList _ aes) (EList _ bes) = aes == bes (==) (EParticle _ ap') (EParticle _ bp) = ap' == bp (==) (ETop _) (ETop _) = True (==) (EVM _ _) (EVM _ _) = False (==) _ _ = False instance Error AtomoError where strMsg = Error . string instance Show Channel where show _ = "Channel" instance Show ORef where show _ = "ORef" instance Show Continuation where show _ = "Continuation" instance Show (VM a) where show _ = "VM" instance Typeable (VM a) where typeOf _ = mkTyConApp (mkTyCon "VM") [typeOf ()] startEnv :: Env startEnv = Env { top = error "top object not set" , primitives = IDs { idMatch = error "idMatch not set" , idObject = error "idObject not set" , idBlock = error "idBlock not set" , idBoolean = error "idBoolean not set" , idChar = error "idChar not set" , idContinuation = error "idContinuation not set" , idDouble = error "idDouble not set" , idExpression = error "idExpression not set" , idHaskell = error "idHaskell not set" , idInteger = error "idInteger not set" , idList = error "idList not set" , idMessage = error "idMessage not set" , idMethod = error "idMethod not set" , idParticle = error "idParticle not set" , idProcess = error "idProcess not set" , idPattern = error "idPattern not set" , idRational = error "idRational not set" , idString = error "idString not set" } , channel = error "channel not set" , halt = error "halt not set" , loadPath = [] , loaded = [] , stack = [] , parserState = startParserState } -- | evaluate x with e as the environment runWith :: VM Value -> Env -> IO (Either AtomoError Value) runWith x e = evalStateT (runContT (runErrorT x) return) e -- | evaluate x with e as the environment runVM :: VM Value -> Env -> IO (Either AtomoError Value, Env) runVM x e = runStateT (runContT (runErrorT x) return) e ----------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------ ----------------------------------------------------------------------------- particle :: String -> Value {-# INLINE particle #-} particle = Particle . PMSingle keyParticle :: [String] -> [Maybe Value] -> Value {-# INLINE keyParticle #-} keyParticle ns vs = Particle $ PMKeyword ns vs keyParticleN :: [String] -> [Value] -> Value {-# INLINE keyParticleN #-} keyParticleN ns vs = keyParticle ns (Nothing:map Just vs) raise :: [String] -> [Value] -> VM a {-# INLINE raise #-} raise ns vs = throwError . Error $ keyParticleN ns vs raise' :: String -> VM a {-# INLINE raise' #-} raise' = throwError . Error . particle string :: String -> Value {-# INLINE string #-} string = String . T.pack haskell :: Typeable a => a -> Value {-# INLINE haskell #-} haskell = Haskell . toDyn fromHaskell :: Typeable a => String -> Value -> VM a fromHaskell t (Haskell d) = case fromDynamic d of Just a -> return a Nothing -> throwError (DynamicNeeded t) fromHaskell t _ = throwError (DynamicNeeded t) fromHaskell' :: Typeable a => String -> Value -> a fromHaskell' t (Haskell d) = case fromDynamic d of Just a -> a Nothing -> error ("needed Haskell value of type " ++ t) fromHaskell' t _ = error ("needed haskell value of type " ++ t) list :: [Value] -> Value list = List . V.fromList fromText :: T.Text -> String fromText = T.unpack fromList :: Value -> [Value] fromList (List vr) = V.toList vr fromList v = error $ "no fromList for: " ++ show v single :: String -> Value -> Message {-# INLINE single #-} single n = Single (hash n) n keyword :: [String] -> [Value] -> Message {-# INLINE keyword #-} keyword ns = Keyword (hash ns) ns psingle :: String -> Pattern -> Pattern {-# INLINE psingle #-} psingle n = PSingle (hash n) n pkeyword :: [String] -> [Pattern] -> Pattern {-# INLINE pkeyword #-} pkeyword ns = PKeyword (hash ns) ns esingle :: String -> Expr -> EMessage {-# INLINE esingle #-} esingle n = ESingle (hash n) n ekeyword :: [String] -> [Expr] -> EMessage {-# INLINE ekeyword #-} ekeyword ns = EKeyword (hash ns) ns -- | Fill in the empty values of a particle. The number of values missing -- is expected to be equal to the number of values provided. completeKP :: [Maybe Value] -> [Value] -> [Value] completeKP [] [] = [] completeKP (Nothing:mvs') (v:vs') = v : completeKP mvs' vs' completeKP (Just v:mvs') vs' = v : completeKP mvs' vs' completeKP mvs' vs' = error $ "impossible: completeKP on " ++ show (mvs', vs') -- | 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 value? 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 Reference? isReference :: Value -> Bool isReference (Reference _) = True isReference _ = False -- | Is a value a String? isString :: Value -> Bool isString (String _) = True isString _ = False