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