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 55 "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 84 "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 103 "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 Generic

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 148 "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 168 "src/ehc/Gam/DataGam.chs" #-}
dtiOffsetOfFld :: HsName -> DataTagInfo -> Fld
dtiOffsetOfFld fldNm dti = dfiOffset $ panicJust "dtiOffsetOfFld" $ Map.lookup fldNm $ dtiFldMp dti

{-# LINE 173 "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 183 "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, Generic)

{-# LINE 196 "src/ehc/Gam/DataGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
-- | Implementation details for datatype, type/kind of a datatype are (also) stored in separate environments (TyGam, TyKiGam)
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}
      }
    deriving Generic

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 245 "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 254 "src/ehc/Gam/DataGam.chs" #-}
dgiIsRec :: DataGamInfo -> Bool
dgiIsRec dgi = dgiVariant dgi == DataGamInfoVariant_Rec

{-# LINE 259 "src/ehc/Gam/DataGam.chs" #-}
type DataGam = Gam HsName DataGamInfo

{-# LINE 263 "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 304 "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 319 "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 326 "src/ehc/Gam/DataGam.chs" #-}
emptyDataGamInfo, emptyDGI :: DataGamInfo
emptyDataGamInfo = mkDGIPlain hsnUnknown (appDbg "emptyDataGamInfo") (appDbg "mkDGIPlain")  [] Map.empty
emptyDGI = emptyDataGamInfo

{-# LINE 332 "src/ehc/Gam/DataGam.chs" #-}
dgiConstrTagAssocL :: DataGamInfo -> AssocL HsName DataTagInfo
dgiConstrTagAssocL dgi = [ (cn,panicJust "dgiConstrTagAssocL" $ Map.lookup cn $ dgiConstrTagMp dgi) | cn <- dgiConstrNmL dgi ]

{-# LINE 337 "src/ehc/Gam/DataGam.chs" #-}
dgiDtiOfCon :: HsName -> DataGamInfo -> DataTagInfo
dgiDtiOfCon conNm dgi = panicJust "dgiDtiOfCon" $ Map.lookup conNm $ dgiConstrTagMp dgi

{-# LINE 342 "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 359 "src/ehc/Gam/DataGam.chs" #-}
dataGamDgiOfTy :: Ty -> DataGam -> Maybe DataGamInfo
dataGamDgiOfTy conTy dg = dataGamLookup (tyAppFunConNm conTy) dg

{-# LINE 364 "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 381 "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 393 "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 401 "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 414 "src/ehc/Gam/DataGam.chs" #-}
dgiIsEnumable :: DataGamInfo -> Bool
dgiIsEnumable dgi = dgiMaxConstrArity dgi == 0

{-# LINE 423 "src/ehc/Gam/DataGam.chs" #-}
deriving instance Typeable DataFldInfo

deriving instance Typeable DataConFldAnnInfo

deriving instance Typeable DataTagInfo

deriving instance Typeable DataFldInConstr

{-# LINE 433 "src/ehc/Gam/DataGam.chs" #-}
deriving instance Typeable DataGamInfo

{-# LINE 437 "src/ehc/Gam/DataGam.chs" #-}
deriving instance Typeable DataGamInfoVariant

{-# LINE 441 "src/ehc/Gam/DataGam.chs" #-}
instance Serialize DataGamInfoVariant

{-# LINE 462 "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 DataFldInConstr where
  sput (DataFldInConstr a) = sput a
  sget = liftM DataFldInConstr sget

{-# LINE 476 "src/ehc/Gam/DataGam.chs" #-}
instance Serialize DataTagInfo
instance Serialize DataGamInfo