module UHC.Light.Compiler.Gam.DataGam ( DataFldMp, DataFldInfo (..), emptyDataFldInfo , DataConFldAnnInfo (..), emptyDataConFldAnnInfo , DataTagInfo (..), emptyDataTagInfo, DataConstrTagMp , DataGamInfo (..) , DataGam , mkDGI , mkDGIPlain , emptyDataGamInfo, emptyDGI , dgiDtiOfCon , dataGamLookup, dataGamLookupErr , dataGamDgiOfTy , dtiOffsetOfFld , DataFldInConstr (..), DataFldInConstrMp , mkDGIForCodegenOnly , dataGamDTIsOfTyNm, dataGamDTIsOfTy , dataGamTagsOfTy, dataGamTagsOfTyNm , dataGamLookupTag , dataGamTagLookup , dgiIsEnumable , dgiConstrTagAssocL , DataGamInfoVariant (..) , dgiMbNewtype, dgiIsNewtype , dgiIsRec ) where import UHC.Util.Pretty import UHC.Util.Utils import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Base.TermLike import UHC.Light.Compiler.Base.HsName.Builtin import UHC.Light.Compiler.Ty import UHC.Light.Compiler.Ty.Pretty import UHC.Light.Compiler.Gam import UHC.Light.Compiler.Error import qualified Data.Map as Map import qualified Data.Set as Set import UHC.Light.Compiler.VarMp import UHC.Light.Compiler.Substitutable import UHC.Light.Compiler.Ty.Trf.Quantify import UHC.Light.Compiler.Base.Debug import UHC.Util.Pretty import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize import Data.Maybe {-# LINE 48 "src/ehc/Gam/DataGam.chs" #-} -- | per named field info -- If this changes, also change {%{EH}ConfigInternalVersions} data DataFldInfo = DataFldInfo { dfiOffset :: !Fld } deriving Show type DataFldMp = Map.Map HsName DataFldInfo emptyDataFldInfo = DataFldInfo noFld {-# LINE 68 "src/ehc/Gam/DataGam.chs" #-} -- | per positional constructor field annotation like info -- If this changes, also change {%{EH}ConfigInternalVersions} data DataConFldAnnInfo = DataConFldAnnInfo { dcfaiStrictness :: !Strictness } deriving Show emptyDataConFldAnnInfo :: DataConFldAnnInfo emptyDataConFldAnnInfo = DataConFldAnnInfo Strictness_NonStrict {-# LINE 87 "src/ehc/Gam/DataGam.chs" #-} -- If this changes, also change {%{EH}ConfigInternalVersions} data DataTagInfo = DataTagInfo { dtiFldMp :: !DataFldMp -- map of field names to offset , dtiFldTyL :: !FldTyL -- association list of maybe a field name with types , dtiConFldAnnL :: ![DataConFldAnnInfo] -- per constructor field (with or without name) annotation info , dtiConNm :: !HsName -- constructor name (duplicate of key of gamma leading to this info) , dtiConTy :: !Ty -- type of constructor, without final tyVarMp applied , dtiCTag :: !CTag -- tag of constructor , dtiFldRefL :: ![Fld] -- list of offset/references positionally consistent with (e.g.) dtiFldTyL , dtiMbFixityPrio :: !(Maybe (Int,Fixity)) -- if defined as infix, with priority } deriving Show type DataConstrTagMp = Map.Map HsName DataTagInfo emptyDataTagInfo = DataTagInfo Map.empty [] [] hsnUnknown (appDbg "emptyDataTagInfo") emptyCTag [] Nothing {-# LINE 118 "src/ehc/Gam/DataGam.chs" #-} dtiOffsetOfFld :: HsName -> DataTagInfo -> Fld dtiOffsetOfFld fldNm dti = dfiOffset $ panicJust "dtiOffsetOfFld" $ Map.lookup fldNm $ dtiFldMp dti {-# LINE 123 "src/ehc/Gam/DataGam.chs" #-} -- If this changes, also change {%{EH}ConfigInternalVersions} data DataFldInConstr = DataFldInConstr { dficInTagMp :: !(Map.Map CTag Fld) } type DataFldInConstrMp = Map.Map HsName DataFldInConstr {-# LINE 133 "src/ehc/Gam/DataGam.chs" #-} -- | specific info about what a DataGamInfo encodes -- If this changes, also change {%{EH}ConfigInternalVersions} data DataGamInfoVariant = DataGamInfoVariant_Plain -- plain data type | DataGamInfoVariant_Newtype -- newtype variation Ty -- the type lambda corresponding to a newtype | DataGamInfoVariant_Rec -- tuple, record deriving Eq {-# LINE 146 "src/ehc/Gam/DataGam.chs" #-} -- If this changes, also change {%{EH}ConfigInternalVersions} data DataGamInfo = DataGamInfo { dgiTyNm :: !HsName -- type name (duplicate of key of gamma leading to this info) , dgiDataTy :: !Ty -- the type sum of product , dgiDataKi :: !Ty -- the kind , dgiConstrNmL :: ![HsName] -- all constructor names , dgiConstrTagMp :: !DataConstrTagMp -- per constructor info , dgiFldInConstrMp :: !DataFldInConstrMp -- map from field name to all constructors having the field , dgiVariant :: !DataGamInfoVariant , dgiMaxConstrArity :: !Int , dgiMbGenerInfo :: !(Maybe Int) -- max kind arity for generic behavior, currently \in {0,1} } instance Show DataGamInfo where show _ = "DataGamInfo" {-# LINE 176 "src/ehc/Gam/DataGam.chs" #-} dgiMbNewtype :: DataGamInfo -> Maybe Ty dgiMbNewtype (DataGamInfo {dgiVariant = DataGamInfoVariant_Newtype t}) = Just t dgiMbNewtype _ = Nothing dgiIsNewtype :: DataGamInfo -> Bool dgiIsNewtype = isJust . dgiMbNewtype {-# LINE 185 "src/ehc/Gam/DataGam.chs" #-} dgiIsRec :: DataGamInfo -> Bool dgiIsRec dgi = dgiVariant dgi == DataGamInfoVariant_Rec {-# LINE 190 "src/ehc/Gam/DataGam.chs" #-} type DataGam = Gam HsName DataGamInfo {-# LINE 194 "src/ehc/Gam/DataGam.chs" #-} mkDGI :: HsName -> Ty -> Ty -> [HsName] -> DataConstrTagMp -> DataGamInfoVariant -> Maybe Int -> DataGamInfo mkDGI tyNm dty ki cNmL m nt mbGener = DataGamInfo tyNm dty ki cNmL m' fm nt mx mbGener where fm = Map.map DataFldInConstr $ Map.unionsWith Map.union $ [ Map.singleton f (Map.singleton (dtiCTag ci) (dfiOffset fi)) | ci <- Map.elems m', (f,fi) <- Map.toList $ dtiFldMp ci ] mx = maximum ( (if Map.null m then (-1) else (ctagMaxArity $ dtiCTag $ head $ Map.elems m)) : [ ctagArity $ dtiCTag dti | dti <- Map.elems m ] ) m' = Map.map (\dti -> dti {dtiCTag = patchTyInfoCTag tyNm mx $ dtiCTag dti}) m {-# LINE 235 "src/ehc/Gam/DataGam.chs" #-} mkDGIPlain :: HsName -> Ty -> Ty -> [HsName] -> DataConstrTagMp -> DataGamInfo mkDGIPlain tyNm dty dki cNmL m = mkDGI tyNm dty dki cNmL m DataGamInfoVariant_Plain Nothing {-# LINE 250 "src/ehc/Gam/DataGam.chs" #-} -- | Construct a datatype info as extracted from (e.g.) Core intended only for codegen (i.e. no type system stuff). mkDGIForCodegenOnly :: HsName -> DataConstrTagMp -> DataGamInfo mkDGIForCodegenOnly tyNm m = mkDGIPlain tyNm Ty_Any Ty_Any (Map.keys m) m {-# LINE 257 "src/ehc/Gam/DataGam.chs" #-} emptyDataGamInfo, emptyDGI :: DataGamInfo emptyDataGamInfo = mkDGIPlain hsnUnknown (appDbg "emptyDataGamInfo") (appDbg "mkDGIPlain") [] Map.empty emptyDGI = emptyDataGamInfo {-# LINE 263 "src/ehc/Gam/DataGam.chs" #-} dgiConstrTagAssocL :: DataGamInfo -> AssocL HsName DataTagInfo dgiConstrTagAssocL dgi = [ (cn,panicJust "dgiConstrTagAssocL" $ Map.lookup cn $ dgiConstrTagMp dgi) | cn <- dgiConstrNmL dgi ] {-# LINE 268 "src/ehc/Gam/DataGam.chs" #-} dgiDtiOfCon :: HsName -> DataGamInfo -> DataTagInfo dgiDtiOfCon conNm dgi = panicJust "dgiDtiOfCon" $ Map.lookup conNm $ dgiConstrTagMp dgi {-# LINE 273 "src/ehc/Gam/DataGam.chs" #-} dataGamLookup :: HsName -> DataGam -> Maybe DataGamInfo dataGamLookup nm g = case gamLookup nm g of Nothing | hsnIsProd nm -- ??? should not be necessary, in variant 7 where tuples are represented by records -> Just emptyDataGamInfo Just dgi -> Just dgi _ -> Nothing dataGamLookupErr :: HsName -> DataGam -> (DataGamInfo,ErrL) dataGamLookupErr n g = case dataGamLookup n g of Nothing -> (emptyDGI,[rngLift emptyRange mkErr_NamesNotIntrod "data" [n]]) Just tgi -> (tgi,[]) {-# LINE 290 "src/ehc/Gam/DataGam.chs" #-} dataGamDgiOfTy :: Ty -> DataGam -> Maybe DataGamInfo dataGamDgiOfTy conTy dg = dataGamLookup (tyAppFunConNm conTy) dg {-# LINE 295 "src/ehc/Gam/DataGam.chs" #-} dataGamDTIsOfTyNm :: HsName -> DataGam -> Maybe [DataTagInfo] dataGamDTIsOfTyNm tn g = fmap (assocLElts . dgiConstrTagAssocL) $ gamLookup tn $ g dataGamDTIsOfTy :: Ty -> DataGam -> Maybe [DataTagInfo] dataGamDTIsOfTy = dataGamDTIsOfTyNm . tyDataTyNm {-# INLINE dataGamDTIsOfTy #-} {-# LINE 312 "src/ehc/Gam/DataGam.chs" #-} dataGamTagsOf :: (t -> DataGam -> Maybe [DataTagInfo]) -> t -> DataGam -> Maybe [CTag] dataGamTagsOf lkup t g = fmap (map dtiCTag) (lkup t g) {-# INLINE dataGamTagsOf #-} dataGamTagsOfTy :: Ty -> DataGam -> Maybe [CTag] dataGamTagsOfTy = dataGamTagsOf dataGamDTIsOfTy dataGamTagsOfTyNm :: HsName -> DataGam -> Maybe [CTag] dataGamTagsOfTyNm = dataGamTagsOf dataGamDTIsOfTyNm {-# LINE 324 "src/ehc/Gam/DataGam.chs" #-} dataGamLookupTag :: HsName -> HsName -> DataGam -> Maybe CTag dataGamLookupTag t c g = do dgi <- dataGamLookup t g dti <- Map.lookup c $ dgiConstrTagMp dgi return $ dtiCTag dti {-# LINE 332 "src/ehc/Gam/DataGam.chs" #-} dataGamTagLookup :: TagLike t => t -> DataGam -> Maybe (DataGamInfo,DataTagInfo) dataGamTagLookup tag g | tagIsData tag = do dgi <- dataGamLookup (tagDataTypeNm tag) g dti <- Map.lookup (tagDataConstrNm tag) $ dgiConstrTagMp dgi return (dgi,dti) | otherwise = Nothing {-# LINE 345 "src/ehc/Gam/DataGam.chs" #-} dgiIsEnumable :: DataGamInfo -> Bool dgiIsEnumable dgi = dgiMaxConstrArity dgi == 0 {-# LINE 354 "src/ehc/Gam/DataGam.chs" #-} deriving instance Typeable DataFldInfo deriving instance Data DataFldInfo deriving instance Typeable DataConFldAnnInfo deriving instance Data DataConFldAnnInfo deriving instance Typeable DataTagInfo deriving instance Data DataTagInfo deriving instance Typeable DataFldInConstr deriving instance Data DataFldInConstr deriving instance Typeable DataGamInfo deriving instance Data DataGamInfo {-# LINE 371 "src/ehc/Gam/DataGam.chs" #-} deriving instance Typeable DataGamInfoVariant deriving instance Data DataGamInfoVariant {-# LINE 376 "src/ehc/Gam/DataGam.chs" #-} instance Serialize DataGamInfoVariant where sput (DataGamInfoVariant_Plain ) = sputWord8 0 sput (DataGamInfoVariant_Newtype a) = sputWord8 1 >> sput a sput (DataGamInfoVariant_Rec ) = sputWord8 2 sget = do t <- sgetWord8 case t of 0 -> return DataGamInfoVariant_Plain 1 -> liftM DataGamInfoVariant_Newtype sget 2 -> return DataGamInfoVariant_Rec {-# LINE 393 "src/ehc/Gam/DataGam.chs" #-} instance Serialize DataFldInfo where sput (DataFldInfo a) = sput a sget = liftM DataFldInfo sget instance Serialize DataConFldAnnInfo where sput (DataConFldAnnInfo a) = sput a sget = liftM DataConFldAnnInfo sget instance Serialize DataTagInfo where sput (DataTagInfo a b c d e f g h) = sput a >> sput b >> sput c >> sput d >> sput e >> sput f >> sput g >> sput h sget = liftM8 DataTagInfo sget sget sget sget sget sget sget sget instance Serialize DataFldInConstr where sput (DataFldInConstr a) = sput a sget = liftM DataFldInConstr sget instance Serialize DataGamInfo where sput (DataGamInfo a b c d e f g h i) = sput a >> sput b >> sput c >> sput d >> sput e >> sput f >> sput g >> sput h >> sput i sget = liftM9 DataGamInfo sget sget sget sget sget sget sget sget sget