module Curry.FlatCurry.Typed.Type
( module Curry.FlatCurry.Typed.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 TProg = TProg String [String] [TypeDecl] [TFuncDecl] [OpDecl]
deriving (Eq, Read, Show)
data TFuncDecl = TFunc QName Int Visibility TypeExpr TRule
deriving (Eq, Read, Show)
data TRule
= TRule [(VarIndex, TypeExpr)] TExpr
| TExternal TypeExpr String
deriving (Eq, Read, Show)
data TExpr
= TVarE TypeExpr VarIndex
| TLit TypeExpr Literal
| TComb TypeExpr CombType QName [TExpr]
| TLet [((VarIndex, TypeExpr), TExpr)] TExpr
| TFree [(VarIndex, TypeExpr)] TExpr
| TOr TExpr TExpr
| TCase CaseType TExpr [TBranchExpr]
| TTyped TExpr TypeExpr
deriving (Eq, Read, Show)
data TBranchExpr = TBranch TPattern TExpr
deriving (Eq, Read, Show)
data TPattern
= TPattern TypeExpr QName [(VarIndex, TypeExpr)]
| TLPattern TypeExpr Literal
deriving (Eq, Read, Show)
instance Typeable TRule where
typeOf (TRule args e) = foldr (FuncType . snd) (typeOf e) args
typeOf (TExternal ty _) = ty
instance Typeable TExpr where
typeOf (TVarE ty _) = ty
typeOf (TLit ty _) = ty
typeOf (TComb ty _ _ _) = ty
typeOf (TLet _ e) = typeOf e
typeOf (TFree _ e) = typeOf e
typeOf (TOr e _) = typeOf e
typeOf (TCase _ _ (e:_)) = typeOf e
typeOf (TTyped _ ty) = ty
typeOf (TCase _ _ []) = error $ "Curry.FlatCurry.Typed.Type.typeOf: " ++
"empty list in case expression"
instance Typeable TPattern where
typeOf (TPattern ty _ _) = ty
typeOf (TLPattern ty _) = ty
instance Typeable TBranchExpr where
typeOf (TBranch _ e) = typeOf e
instance Binary TProg where
put (TProg mid im tys fus ops) =
put mid >> put im >> put tys >> put fus >> put ops
get = TProg <$> get <*> get <*> get <*> get <*> get
instance Binary TFuncDecl where
put (TFunc qid arity vis ty r) =
put qid >> put arity >> put vis >> put ty >> put r
get = TFunc <$> get <*> get <*> get <*> get <*> get
instance Binary TRule where
put (TRule alts e) = putWord8 0 >> put alts >> put e
put (TExternal ty n ) = putWord8 1 >> put ty >> put n
get = do
x <- getWord8
case x of
0 -> liftM2 TRule get get
1 -> liftM2 TExternal get get
_ -> fail "Invalid encoding for TRule"
instance Binary TExpr where
put (TVarE ty v) = putWord8 0 >> put ty >> put v
put (TLit ty l) = putWord8 1 >> put ty >> put l
put (TComb ty cty qid es) =
putWord8 2 >> put ty >> put cty >> put qid >> put es
put (TLet bs e) = putWord8 3 >> put bs >> put e
put (TFree vs e) = putWord8 4 >> put vs >> put e
put (TOr e1 e2) = putWord8 5 >> put e1 >> put e2
put (TCase cty ty as) = putWord8 6 >> put cty >> put ty >> put as
put (TTyped e ty) = putWord8 7 >> put e >> put ty
get = do
x <- getWord8
case x of
0 -> liftM2 TVarE get get
1 -> liftM2 TLit get get
2 -> liftM4 TComb get get get get
3 -> liftM2 TLet get get
4 -> liftM2 TFree get get
5 -> liftM2 TOr get get
6 -> liftM3 TCase get get get
7 -> liftM2 TTyped get get
_ -> fail "Invalid encoding for TExpr"
instance Binary TBranchExpr where
put (TBranch p e) = put p >> put e
get = liftM2 TBranch get get
instance Binary TPattern where
put (TPattern ty qid vs) = putWord8 0 >> put ty >> put qid >> put vs
put (TLPattern ty l ) = putWord8 1 >> put ty >> put l
get = do
x <- getWord8
case x of
0 -> liftM3 TPattern get get get
1 -> liftM2 TLPattern get get
_ -> fail "Invalid encoding for TPattern"