module UHC.Light.Compiler.CodeGen.Tag
( CTag (..), ctagIsRec, ctagTag, ctagChar, ctagInt, emptyCTag
, mkOnlyConInfoCTag, patchTyInfoCTag
, ctag, ppCTag, ppCTagInt
, tagBoolTrue, tagBoolFalse
, tagListCons, tagListNil
, TagDataInfo (..)
, mkTyIsConTagInfo, mkConTagInfo, emptyTagDataInfo
, tagInfoInt, tagInfoChar
, TagLike (..), tagDataInfo
, CTagsMp, emptyCTagsMp
, mkClassCTag )
where
import Data.Maybe
import Control.Monad
import UHC.Util.Pretty
import UHC.Util.AssocL
import UHC.Light.Compiler.Base.HsName
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Util.Binary
import UHC.Util.Serialize
data CTag
= CTagRec
| CTag
{ ctagTyNm :: !HsName
, ctagNm :: !HsName
, ctagTag' :: !Int
, ctagArity :: !Int
, ctagMaxArity :: !Int
}
deriving (Show,Eq,Ord)
ctagIsRec :: CTag -> Bool
ctagIsRec CTagRec = True
ctagIsRec t = False
ctagTag :: CTag -> Int
ctagTag CTagRec = 0
ctagTag t = ctagTag' t
ctagInt = CTag hsnInt hsnInt 0 1 1
ctagChar = CTag hsnChar hsnChar 0 1 1
emptyCTag = CTag hsnUnknown hsnUnknown 0 0 0
mkOnlyConInfoCTag :: HsName -> Int -> Int -> CTag
mkOnlyConInfoCTag conNm tg arity = emptyCTag {ctagNm = conNm, ctagTag' = tg, ctagArity = arity}
patchTyInfoCTag :: HsName -> Int -> CTag -> CTag
patchTyInfoCTag tyNm maxArity t = t {ctagTyNm = tyNm, ctagMaxArity = maxArity}
mkClassCTag :: HsName -> Int -> CTag
mkClassCTag n sz = CTag n n 0 sz sz
ctag :: a -> (HsName -> HsName -> Int -> Int -> Int -> a) -> CTag -> a
ctag n t tg = case tg of {CTag tn cn i a ma -> t tn cn i a ma; _ -> n}
ppCTag :: CTag -> PP_Doc
ppCTag = ctag (pp "Rec") (\tn cn t a ma -> pp t >|< "/" >|< pp cn >|< "/" >|< pp a >|< "/" >|< pp ma)
ppCTagInt :: CTag -> PP_Doc
ppCTagInt = ctag (pp "-1") (\_ _ t _ _ -> pp t)
instance PP CTag where
pp = ppCTag
tagBoolTrue, tagBoolFalse :: Int
tagBoolTrue = 1
tagBoolFalse = 0
tagListCons, tagListNil :: Int
tagListCons = 0
tagListNil = 1
data TagDataInfo = TagDataInfo
{ tagDataInfoTypeNm :: !HsName
, tagDataInfoConstrNm :: !HsName
}
deriving (Show)
instance Eq TagDataInfo where
i1 == i2 = tagDataInfoConstrNm i1 == tagDataInfoConstrNm i2
instance Ord TagDataInfo where
i1 `compare` i2 = tagDataInfoConstrNm i1 `compare` tagDataInfoConstrNm i2
mkTyConTagInfo :: HsName -> HsName -> TagDataInfo
mkTyConTagInfo = TagDataInfo
mkTyIsConTagInfo :: HsName -> TagDataInfo
mkTyIsConTagInfo n = mkTyConTagInfo n n
mkConTagInfo :: HsName -> TagDataInfo
mkConTagInfo cn = mkTyConTagInfo hsnUnknown cn
emptyTagDataInfo = mkTyConTagInfo hsnUnknown hsnUnknown
tagInfoInt = mkTyIsConTagInfo hsnInt
tagInfoChar = mkTyIsConTagInfo hsnChar
class TagLike t where
tagIsData :: t -> Bool
tagIsTup :: t -> Bool
tagMbDataInfo :: t -> Maybe TagDataInfo
tagDataTypeNm :: t -> HsName
tagDataConstrNm :: t -> HsName
tagDataTag :: t -> Int
tagMbDataInfo t = if tagIsData t then Just (emptyTagDataInfo {tagDataInfoTypeNm = tagDataTypeNm t, tagDataInfoConstrNm = tagDataConstrNm t}) else Nothing
tagDataTypeNm = tagDataInfoTypeNm . tagDataInfo
tagDataConstrNm = tagDataInfoConstrNm . tagDataInfo
tagIsData = isJust . tagMbDataInfo
tagIsTup = not . tagIsData
tagDataInfo :: TagLike t => t -> TagDataInfo
tagDataInfo = fromJust . tagMbDataInfo
instance TagLike CTag where
tagMbDataInfo = ctag Nothing (\tn cn _ _ _ -> Just (emptyTagDataInfo {tagDataInfoTypeNm = tn, tagDataInfoConstrNm = cn}))
tagDataTag = ctagTag'
tagIsTup = ctagIsRec
tagDataTypeNm = ctagTyNm
tagDataConstrNm = ctagNm
instance PP TagDataInfo where
pp i = tagDataInfoTypeNm i >|< "#" >|< tagDataInfoConstrNm i
type CTagsMp = AssocL HsName (AssocL HsName CTag)
emptyCTagsMp :: CTagsMp
emptyCTagsMp = []
deriving instance Typeable CTag
deriving instance Data CTag
instance Serialize CTag where
sput = sputShared
sget = sgetShared
sputNested (CTagRec ) = sputWord8 0
sputNested (CTag a b c d e) = sputWord8 1 >> sput a >> sput b >> sput c >> sput d >> sput e
sgetNested
= do t <- sgetWord8
case t of
0 -> return CTagRec
1 -> liftM5 CTag sget sget sget sget sget