module UHC.Light.Compiler.Gam.DataGam ( DataFldMp, DataFldInfo (..), emptyDataFldInfo , DataConFldAnnInfo (..), emptyDataConFldAnnInfo , DataTagInfo (..), emptyDataTagInfo, DataConstrTagMp , fldTyLEnsureLabels, mkFldRefAndMp , 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 Control.Applicative ((<|>)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import UHC.Light.Compiler.VarMp import UHC.Light.Compiler.Substitutable import UHC.Light.Compiler.Ty.Trf.Quantify import UHC.Light.Compiler.CodeGen.RefGenerator import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize {-# LINE 52 "src/ehc/Gam/DataGam.chs" #-} -- | per named field info -- If this changes, also change {%{EH}ConfigInternalVersions} data DataFldInfo = DataFldInfo { dfiOffset :: !Fld } instance Show DataFldInfo where show i = show (dfiOffset i) instance PP DataFldInfo where pp = pp . show type DataFldMp = Map.Map HsName DataFldInfo emptyDataFldInfo = DataFldInfo noFld {-# LINE 81 "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 100 "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 } instance Show DataTagInfo where show _ = "DataTagInfo" instance PP DataTagInfo where pp i = dtiConNm i >-< indent 2 ( "flds=" >#< ppCommas [n >#< ppTy t | (n,t) <- dtiFldTyL i] >-< "fldmp=" >#< ppCommas [n >#< t | (n,t) <- Map.toList $ dtiFldMp i] >-< "fldrefs=" >#< ppCommas (dtiFldRefL i) >-< "conty=" >#< ppTy (dtiConTy i) ) type DataConstrTagMp = Map.Map HsName DataTagInfo emptyDataTagInfo = DataTagInfo Map.empty [] [] hsnUnknown (appDbg "emptyDataTagInfo") emptyCTag [] Nothing {-# LINE 144 "src/ehc/Gam/DataGam.chs" #-} -- | Ensure presence of field labels fldTyLEnsureLabels :: FldTyL -> FldTyL fldTyLEnsureLabels = zipWith (\pn (ml,t) -> (ml <|> Just pn, t)) positionalFldNames -- | Construct fld info from FldTyL mkFldRefAndMp :: FldTyL -> (DataFldMp, FldTyL, AssocL HsName Fld) mkFldRefAndMp fldTyL = (fldMp, fldTyL', fldRefL) where fldTyL' = fldTyLEnsureLabels fldTyL fldRefL = refGen 0 1 [ n | (Just n, _) <- fldTyL' ] fldMp = Map.fromList $ catMaybes $ zipWith (\(_,r) (ml,_) -> fmap (\l -> (l,emptyDataFldInfo {dfiOffset = r})) ml) fldRefL fldTyL {-# LINE 164 "src/ehc/Gam/DataGam.chs" #-} dtiOffsetOfFld :: HsName -> DataTagInfo -> Fld dtiOffsetOfFld fldNm dti = dfiOffset $ panicJust "dtiOffsetOfFld" $ Map.lookup fldNm $ dtiFldMp dti {-# LINE 169 "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 179 "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 192 "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 dataty -> 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" instance PP DataGamInfo where pp i@(DataGamInfo {dgiTyNm=nm, dgiDataTy=sumprod, dgiDataKi=ki}) = nm >-< indent 2 ( "sumprod=" >#< ppTy sumprod >-< "ki=" >#< ppTy ki >-< "constrnms=" >#< ppCommas (dgiConstrNmL i) >-< "constrmp=" >#< vlist (Map.toList $ dgiConstrTagMp i) ) {-# LINE 234 "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 243 "src/ehc/Gam/DataGam.chs" #-} dgiIsRec :: DataGamInfo -> Bool dgiIsRec dgi = dgiVariant dgi == DataGamInfoVariant_Rec {-# LINE 248 "src/ehc/Gam/DataGam.chs" #-} type DataGam = Gam HsName DataGamInfo {-# LINE 252 "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 293 "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 308 "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 315 "src/ehc/Gam/DataGam.chs" #-} emptyDataGamInfo, emptyDGI :: DataGamInfo emptyDataGamInfo = mkDGIPlain hsnUnknown (appDbg "emptyDataGamInfo") (appDbg "mkDGIPlain") [] Map.empty emptyDGI = emptyDataGamInfo {-# LINE 321 "src/ehc/Gam/DataGam.chs" #-} dgiConstrTagAssocL :: DataGamInfo -> AssocL HsName DataTagInfo dgiConstrTagAssocL dgi = [ (cn,panicJust "dgiConstrTagAssocL" $ Map.lookup cn $ dgiConstrTagMp dgi) | cn <- dgiConstrNmL dgi ] {-# LINE 326 "src/ehc/Gam/DataGam.chs" #-} dgiDtiOfCon :: HsName -> DataGamInfo -> DataTagInfo dgiDtiOfCon conNm dgi = panicJust "dgiDtiOfCon" $ Map.lookup conNm $ dgiConstrTagMp dgi {-# LINE 331 "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 348 "src/ehc/Gam/DataGam.chs" #-} dataGamDgiOfTy :: Ty -> DataGam -> Maybe DataGamInfo dataGamDgiOfTy conTy dg = dataGamLookup (tyAppFunConNm conTy) dg {-# LINE 353 "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 370 "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 382 "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 390 "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 403 "src/ehc/Gam/DataGam.chs" #-} dgiIsEnumable :: DataGamInfo -> Bool dgiIsEnumable dgi = dgiMaxConstrArity dgi == 0 {-# LINE 412 "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 429 "src/ehc/Gam/DataGam.chs" #-} deriving instance Typeable DataGamInfoVariant deriving instance Data DataGamInfoVariant {-# LINE 434 "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 451 "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