module Curry.FlatCurry.Annotated.Type
( module Curry.FlatCurry.Annotated.Type
, module Curry.FlatCurry.Typeable
, module Curry.FlatCurry.Type
) where
import Data.Binary
import Control.Monad
import Curry.FlatCurry.Typeable
import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex
, TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)
, TypeExpr (..), ConsDecl (..), NewConsDecl (..)
, Literal (..), CombType (..), CaseType (..)
)
data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl]
deriving (Eq, Read, Show)
data AFuncDecl a = AFunc QName Int Visibility TypeExpr (ARule a)
deriving (Eq, Read, Show)
data ARule a
= ARule a [(VarIndex, a)] (AExpr a)
| AExternal a String
deriving (Eq, Read, Show)
data AExpr a
= AVar a VarIndex
| ALit a Literal
| AComb a CombType (QName, a) [AExpr a]
| ALet a [((VarIndex, a), AExpr a)] (AExpr a)
| AFree a [(VarIndex, a)] (AExpr a)
| AOr a (AExpr a) (AExpr a)
| ACase a CaseType (AExpr a) [ABranchExpr a]
| ATyped a (AExpr a) TypeExpr
deriving (Eq, Read, Show)
data ABranchExpr a = ABranch (APattern a) (AExpr a)
deriving (Eq, Read, Show)
data APattern a
= APattern a (QName, a) [(VarIndex, a)]
| ALPattern a Literal
deriving (Eq, Read, Show)
instance Typeable a => Typeable (AExpr a) where
typeOf (AVar a _) = typeOf a
typeOf (ALit a _) = typeOf a
typeOf (AComb a _ _ _) = typeOf a
typeOf (ALet a _ _) = typeOf a
typeOf (AFree a _ _) = typeOf a
typeOf (AOr a _ _) = typeOf a
typeOf (ACase a _ _ _) = typeOf a
typeOf (ATyped a _ _) = typeOf a
instance Typeable a => Typeable (APattern a) where
typeOf (APattern a _ _) = typeOf a
typeOf (ALPattern a _) = typeOf a
instance Binary a => Binary (AProg a) where
put (AProg mid im tys fus ops) =
put mid >> put im >> put tys >> put fus >> put ops
get = AProg <$> get <*> get <*> get <*> get <*> get
instance Binary a => Binary (AFuncDecl a) where
put (AFunc qid arity vis ty r) =
put qid >> put arity >> put vis >> put ty >> put r
get = AFunc <$> get <*> get <*> get <*> get <*> get
instance Binary a => Binary (ARule a) where
put (ARule a alts e) = putWord8 0 >> put a >> put alts >> put e
put (AExternal ty n ) = putWord8 1 >> put ty >> put n
get = do
x <- getWord8
case x of
0 -> liftM3 ARule get get get
1 -> liftM2 AExternal get get
_ -> fail "Invalid encoding for TRule"
instance Binary a => Binary (AExpr a) where
put (AVar a v) = putWord8 0 >> put a >> put v
put (ALit a l) = putWord8 1 >> put a >> put l
put (AComb a cty qid es) =
putWord8 2 >> put a >> put cty >> put qid >> put es
put (ALet a bs e ) = putWord8 3 >> put a >> put bs >> put e
put (AFree a vs e ) = putWord8 4 >> put a >> put vs >> put e
put (AOr a e1 e2) = putWord8 5 >> put a >> put e1 >> put e2
put (ACase a cty ty as) = putWord8 6 >> put a >> put cty >> put ty >> put as
put (ATyped a e ty) = putWord8 7 >> put a >> put e >> put ty
get = do
x <- getWord8
case x of
0 -> liftM2 AVar get get
1 -> liftM2 ALit get get
2 -> liftM4 AComb get get get get
3 -> liftM3 ALet get get get
4 -> liftM3 AFree get get get
5 -> liftM3 AOr get get get
6 -> liftM4 ACase get get get get
7 -> liftM3 ATyped get get get
_ -> fail "Invalid encoding for TExpr"
instance Binary a => Binary (ABranchExpr a) where
put (ABranch p e) = put p >> put e
get = liftM2 ABranch get get
instance Binary a => Binary (APattern a) where
put (APattern a qid vs) = putWord8 0 >> put a >> put qid >> put vs
put (ALPattern a l ) = putWord8 1 >> put a >> put l
get = do
x <- getWord8
case x of
0 -> liftM3 APattern get get get
1 -> liftM2 ALPattern get get
_ -> fail "Invalid encoding for TPattern"