module UHC.Light.Compiler.EH.MainAG_common where import Data.Char import Data.List as List import UHC.Util.Pretty import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Base.TermLike import UHC.Light.Compiler.Base.HsName.Builtin import UHC.Light.Compiler.Opts import UHC.Light.Compiler.Gam.Full import UHC.Light.Compiler.Error import UHC.Light.Compiler.Error.Pretty import UHC.Light.Compiler.EH import UHC.Light.Compiler.Ty.Pretty import UHC.Light.Compiler.Ty.FitsInCommon import UHC.Light.Compiler.Ty.FitsIn import qualified UHC.Util.FastSeq as Seq import UHC.Util.Utils import UHC.Light.Compiler.Base.Trace import UHC.Light.Compiler.Base.UnderDev import UHC.Light.Compiler.VarMp import UHC.Light.Compiler.Substitutable import Data.Maybe import UHC.Light.Compiler.Ty.Utils1 import UHC.Light.Compiler.Ty.Trf.Quantify import UHC.Light.Compiler.Ty.Trf.Instantiate import UHC.Light.Compiler.Ty import UHC.Light.Compiler.Ty.FitsInCommon2 import UHC.Light.Compiler.Ty.FIEnv2 import qualified Data.Set as Set import qualified Data.Map as Map import Data.Set (Set) import Data.Map (Map) import UHC.Light.Compiler.Ty.Trf.FreshVar import UHC.Light.Compiler.Ty.Ftv import UHC.Util.Utils (groupSortOn) import Control.Applicative ((<|>)) import UHC.Light.Compiler.AbstractCore import UHC.Light.Compiler.AbstractCore.Utils import UHC.Light.Compiler.Core import UHC.Light.Compiler.Core.FFI import UHC.Light.Compiler.Core.Utils import UHC.Light.Compiler.Core.Pretty import UHC.Light.Compiler.Foreign.Extract import UHC.Light.Compiler.LamInfo import UHC.Light.Compiler.CodeGen.RefGenerator import qualified UHC.Light.Compiler.Core.SysF.AsTy as SysF import UHC.Light.Compiler.FinalEnv import UHC.Light.Compiler.Core.BindExtract import UHC.Light.Compiler.Core.Subst import Control.Monad.State import UHC.Light.Compiler.Ty.Utils2 import UHC.Light.Compiler.Base.Target import UHC.Light.Compiler.Core.Coercion import UHC.Light.Compiler.Ty.Trf.MergePreds import UHC.Light.Compiler.Ty.Trf.Canonic import UHC.Light.Compiler.Gam.ClGam import UHC.Light.Compiler.Pred import UHC.Light.Compiler.Pred.CtxtRedOnly.RedGraph (redPruneReductionsUntil) import UHC.Util.CHR import UHC.Light.Compiler.CHR.CtxtRedOnly.Constraint import UHC.Light.Compiler.CHR.CtxtRedOnly.Guard import UHC.Light.Compiler.Pred.CtxtRedOnly.ToCHR import UHC.Light.Compiler.Pred.CtxtRedOnly.Heuristics import UHC.Light.Compiler.Pred.CtxtRedOnly.Evidence import UHC.Light.Compiler.CHR.CtxtRedOnly.Solve import UHC.Light.Compiler.Pred.CtxtRedOnly.EvidenceToCore import UHC.Light.Compiler.Gam.ClassDefaultGam import UHC.Light.Compiler.Ty.Trf.BetaReduce (tyBetaRedFull) import UHC.Light.Compiler.Module.ImportExport import UHC.Light.Compiler.Ty.UsedNames import UHC.Light.Compiler.CodeGen.ImportUsedModules import UHC.Light.Compiler.CodeGen.ModuleImportExportImpl import UHC.Light.Compiler.CodeGen.BuiltinPrims import UHC.Light.Compiler.Foreign import UHC.Light.Compiler.Foreign import UHC.Light.Compiler.Foreign.Pretty import UHC.Light.Compiler.Deriving import UHC.Light.Compiler.Generics import UHC.Light.Compiler.VarMp.Utils -- | The info for generics about datatypes, required higher in the syntax tree type GenerDataInfo = ( ( HsName -- orig type name , [TyVarId] -- data type args , Ty -- kind of type, without kiVarMap yet applied ) , [( CTag -- orig con tag , FldTyL -- field types, with possible label )] , PredScope , Int -- max kind arity over which genericity abstracts, currently \in {0,1} ) type GenerDataInfoMp = Map.Map HsName GenerDataInfo -- | what kind of instance should be generated data GenerInstKind = GenerInstKind_Datatype | GenerInstKind_Selector | GenerInstKind_Constructor HsName -- for a type | GenerInstKind_Representable Int -- remaining arity Proj -- projection info deriving (Show) -- | Info for generics, for generating data instances type GenerDataInstInfo = ( HsName -- original name of type, data , HsName -- instance name , HsName -- class name , GenerInstKind -- what kind of instance , Pred -- the predicate ) -- | Info for generics, for generating repr instances, in particular projection descriptors type GenerTySynProjInfo = ( HsName -- original name of datatype , [TyVarId] -- data type args , PredScope -- predicate scope , [( HsName -- representation type name , Ty -- type synonym itself, i.e. the type lambda , Proj -- projection descriptor , Int -- the arity of remaining type args )] ) mkGenerThing :: thing -> (thing -> thing) -> (thing -> thing -> thing) -> [thing] -> thing mkGenerThing zero one two things = mkSub things where mkSub [ ] = zero mkSub [s] = one s mkSub ss = two (mkSub ss1) (mkSub ss2) where (ss1,ss2) = splitAt (length ss `div` 2) ss mkGenerRepresentableTypeSynTyProj :: EHCOpts -> Int -- the arity of to be supplied type paramaters -> [HsName] -- all type names defined in this binding group (i.e. let) -> (HsName -> Int-> Bool) -- name of type has Representable? -> HsName -- type name -> [TyVarId] -- type args -- -> ([Ty],Ty) -- kind, already split up in args + res -> [(CTag,HsName,FldTyL)] -- tags, constructor type names, with type args -> ( Ty -- type , Proj -- intermediate description of projection ) mkGenerRepresentableTypeSynTyProj opts remArity allTyNmL isRepresentable tyNm tvarArgL -- (kiArgL,kiRes) conNmArgsL = mkTop $ mkSm [ mkAlt tg c (mkPr [ mkLblArg p | p <- ps ]) | (tg,c,ps) <- conNmArgsL ] where lamArity = length tvarArgL - remArity (lamTvarArgL,remTvarArgL) = splitAt lamArity tvarArgL mkC f = appCon $ ehcOptBuiltin opts f mkC2 f i = appCon $ ehcOptBuiltin2 opts f i mkSub (u,pu) (f,pf) = mkGenerThing (mkC u,pu) id (\(x,px) (y,py) -> (appTopApp [mkC f, x, y], pf px py)) mkPr = mkSub (ehbnGenerDataUnit1, Proj_U1 ) (ehbnGenerDataProd, Proj_Prod ) mkSm = mkSub (ehbnGenerDataVoid1, Proj_Void ) (ehbnGenerDataSum , \x y -> Proj_L1 x `Proj_Sum` Proj_R1 y) mkLblArg (mbLbl,t) = ( appTopApp [ mkC ehbnGenerDataMetaS1, sel, t' ], Proj_M1_S1 p ) where (t',p) = mkArg t sel = maybe (mkC ehbnGenerDataNoSelector) (appCon) mbLbl mkArg t = (appTopApp funarg, proj) where (funarg,proj) | isJust mbVar = case elemIndex tvar remTvarArgL of -- TBD: check for kind *, check for one of tvarArgL Just i -> ([ mkC ehbnGenerDataPar1 ], Proj_Par1 [t] (i+1)) _ -> ([ mkC ehbnGenerDataPar0, t ], Proj_K1 [t] ) | remArity > 0 && {- isJust mbCon && -} length args > 0 && isRepr = case (initlast remTvarArgL, initlast args) of (Just (_,tv), Just (firstargs,lastarg)) | maybe False (tv==) $ tyMbVar lastarg -> ([ mkC ehbnGenerDataRec1, appTopApp (fun : firstargs) ], Proj_Rec1 [t] remArity) (_, Just (firstargs,lastarg)) | not $ Set.null $ varFreeSet lastarg -> ( [ mkC ehbnGenerDataComp1, fmapTy, lastarg' ] , Proj_Comp1 [t] fmapTy lastproj ) where (lastarg',lastproj) = mkArg lastarg fmapTy = appTopApp (fun : firstargs) _ -> dflt | otherwise = dflt where mbVar @(~(Just tvar )) = tyMbVar t funArgs @( (fun,args) ) = appUnApp t isRepr = maybe (isJust $ tyMbVar fun) (\con -> isRepresentable con remArity) $ tyMbCon fun dflt = ([ mkC ehbnGenerDataRec0, t ], Proj_K1 [t]) mkAlt tg c (t,p) = (appTopApp [mkC2 ehbnGenerDataMetaCN 1, appCon c, t], Proj_M1 $ Proj_Con tg p) mkTop (t,p) = ( mkTyLam lamTvarArgL (appTopApp [ mkC2 ehbnGenerDataMetaDN 1, appCon tyNm, t ]) , Proj $ Proj_M1 p ) -- eqLastTvar = maybe (const False) (\(_,v) -> maybe False (v==) . tyMbVar) $ initlast tvarArgL -- isRec t = not (null as) || tyConNm f `elem` allTyNmL -- where (f,as) = appUnApp t mkGenerRepresentableTypeSynonymKi :: TyKiGam -> HsName -> Ty mkGenerRepresentableTypeSynonymKi tyKiGam tyNm = maybe (appDbg $ "Generics.mkGenerRepresentableTypeSynonymKi: " ++ show tyNm) (addStar . tkgiKi) $ tyKiGamLookupByName tyNm tyKiGam where addStar ki = appArr (as ++ [kiStar]) r where (as,r) = appUnArr ki -- TBD: sort out additional pol param at end, just like for kinds mkGenerRepresentableTypeSynonymPol :: PolGam -> HsName -> Ty mkGenerRepresentableTypeSynonymPol polGam tyNm = maybe (appDbg $ "Generics.mkGenerRepresentableTypeSynonymPol: " ++ show tyNm) pgiPol $ polGamLookup tyNm polGam type GenerForFitsIn = ( HsName -- field name , HsName -- default value name , Ty -- field type , Ty -- default value type ) -- | determine the orphans given a modulenm, of a nm orphanNmS :: HsName -> HsName -> Set.Set HsName orphanNmS moduleNm nm = case hsnQualifier nm of Just m | m /= moduleNm -> Set.singleton m _ -> Set.empty gathMentrelFilterMpFromSimplifyResult :: HsName -> SimplifyResult -> ModEntRelFilterMp gathMentrelFilterMpFromSimplifyResult moduleNm simpRes = mentrelFilterMpUnions [ mentrelFilterMpSingleton [moduleNm] IdOcc_Val nm | (Reduction {cnstrInfo=RedHow_ByInstance nm _ _}) <- ({- filterMb fromSolverConstraint $ -} chrSolveStateDoneConstraints $ simpresSolveState simpRes :: [Constraint]) ] polGamLookupOrAdd :: UID -> HsName -> PolGam -> PolGam -> (PolGamInfo,PolGam) polGamLookupOrAdd uniq nm polGamLkup polGam = case polGamLookup nm polGamLkup of Nothing -> let t = mkPolVar uniq pgi = mkPGI t in (pgi,gamAdd nm pgi polGam) Just pgi -> (pgi,polGam) -- | behavior configuration of simplify data SimplifyHow = SimplifyHow_Canonicalize -- canonicalize predicates deriving Eq data SimplifyState = SimplifyState { simpToProveHereCnstrMp :: !ConstraintToInfoMap -- new constraints to prove , simpAllCnstrMp :: !ConstraintToInfoMap -- all constraints to prove, including previous , simpRemCnstrTraceMp :: !ConstraintToInfoTraceMp -- remaining to be proven, as Assume's , simpRemOccL :: ![CHRIntermediateUntilAssume] -- same, but only occurrences (as list), with original trace mp split up per pred , simpCannotCnstrTraceMp :: !ConstraintToInfoTraceMp -- cannot be proven , simpVarMp :: !VarMp -- additional substitution , simpEvidMp :: !InfoToEvidenceMap -- map from constraint/pred occurrence to evidence , simpEnv :: !FIIn , simpRes :: !(SimplifyResult) -- simplification work done at a previous call , simpErrs :: ![Err] -- errors } emptySimplifyState :: SimplifyState emptySimplifyState = SimplifyState Map.empty Map.empty Map.empty [] Map.empty emptyVarMp Map.empty (emptyFI :: FIIn) emptySimplifyResult [] simplify' :: [SimplifyHow] -> CHRStore -- available CHR rules -> ClassDefaultGam -- environment/gam for defaulting -> Heuristic -- graph reduction heuristic -> ([CHRIntermediateUntilAssume] -> ([CHRIntermediateUntilAssume],[CHRIntermediateUntilAssume])) -- partition into ambiguous predicates (and others), for defaulting -> ConstraintToInfoMap -- constraints already proven a previous call -> State SimplifyState () simplify' simplifyHow chrStore clDfGam heur partitionUnresolved2AmbigAndOthers toProveHereCnstrMpPrev = do { s <- get ; let -- unique seeds (_,u1,u2,u3) = mkNewLevUID3 $ fiUniq origEnv -- remember for later origEnv = simpEnv s -- canonicalize predicate occurrences (expand type signatures, record fields in same order) ; when (SimplifyHow_Canonicalize `elem` simplifyHow) (do { s <- get ; let (pr,mp) = Map.foldrWithKey (\p c (cm,m) -> let (p',m') = canon s p in (Map.insertWith (++) p' c cm, m' `varUpd` m) ) (Map.empty,emptyVarMp :: VarMp) (simpToProveHereCnstrMp s) ; put (s {simpToProveHereCnstrMp = pr, simpVarMp = mp `varUpd` simpVarMp s}) }) -- adapt env to inhibit bindings for variables freely occurring in predicates, these are fixed (apart from improving substitutions, when resolving defaulting) ; modify (\s -> let e = simpEnv s o = fiFIOpts e in s {simpEnv = e {fiFIOpts = o {fioDontBind = fixedFtv (simpToProveHereCnstrMp s), fioBindCategs = TyVarCateg_Meta : fioBindCategs o}}} ) -- get base result, for backtracking to when restarting for defaulting ; s <- get ; let prevSimplifyRes = simpRes s -- 1st simplification run ; (cannotResCnstrTraceMp,chrSolveAssumablePrOccL) <- fullSimp u1 toProveHereCnstrMpPrev prevSimplifyRes ; modify (\s -> s {simpCannotCnstrTraceMp = cannotResCnstrTraceMp, simpRemOccL = chrSolveAssumablePrOccL}) -- defaulting is done here very crudely, find defaulting candidates, apply the improving substitution, and restart. TBD: this is a hack, do this better, probably when improving subst are done right. ; s <- get ; let (chrSolveAmbigPrOccL,chrSolveAssumablePrOccL) = partitionUnresolved2AmbigAndOthers (simpRemOccL s) ; when ( -- Debug.tr "chrSolveAmbigPrOccL" (ppCommas (simpRemOccL s) >-< ppCommas chrSolveAmbigPrOccL >-< ppCommas chrSolveAssumablePrOccL) $ not (null chrSolveAmbigPrOccL)) (do { let (dfltPrOccL,dfltTyVarMp) = foldr cmb ([],emptyVarMp) chrSolveAmbigPrOccL where cmb :: (CHRPredOcc,x) -> ([CHRPredOcc],VarMp) -> ([CHRPredOcc],VarMp) cmb (o,_) r@(os,m) = maybe r (\m' -> (o:os,m' `varUpd` m)) $ clDfGamLookupDefault (origEnv {fiVarMp = m `varUpd` fiVarMp (simpEnv s)}) (cpoPr o) clDfGam ; when ( -- Debug.tr "dfltPrOccL" (ppCommas (simpRemOccL s) >-< ppCommas dfltPrOccL >-< dfltTyVarMp) $ not (null dfltPrOccL)) -- when a match is found, apply the substitution and kick off proving again (do { modify (\s -> s {simpToProveHereCnstrMp = dfltTyVarMp `varUpd` simpToProveHereCnstrMp s, simpVarMp = dfltTyVarMp `varUpd` simpVarMp s}) ; (cannotResCnstrTraceMp,chrSolveAssumablePrOccL) <- fullSimp u1 toProveHereCnstrMpPrev prevSimplifyRes ; modify (\s -> s {simpCannotCnstrTraceMp = cannotResCnstrTraceMp, simpRemOccL = chrSolveAssumablePrOccL}) }) }) -- (possibly) 2nd simplification run, to deal with unproven constraints which can be assumed or defaulted ; s <- get ; if not (null (simpRemOccL s)) then -- if not all could be proven, assumptions have to be made: clean up, prove again with additional assumptions do { s <- get ; let -- remember for later use chrSimplifyResult = simpRes s -- prune the redgraph, remove that which depends on unresolved predicates redGraphPruned = redPruneReductionsUntil (map fst (simpRemOccL s)) (let m = Set.map cnstrPred $ Map.keysSet (simpToProveHereCnstrMp s) in \p -> Set.member p m) (simpresRedGraph chrSimplifyResult) ; modify (\s -> s {simpRes = chrSimplifyResult {simpresRedGraph = redGraphPruned, simpresRedGraphs = ("simplify pruned",redGraphPruned) : simpresRedGraphs chrSimplifyResult}}) -- (2nd time) RedGraph to Evidence etc ; (_,chrSolveAssumablePrOccL) <- basicSimpRedGraph (simpAllCnstrMp s) ; modify (\s -> s {simpRemOccL = chrSolveAssumablePrOccL}) -- convert to Assume constraints ; s <- get ; let (chrSolveRemCnstrTraceMp,chrSolveEvidMp) = patchUnresolvedWithAssumption ((simpEnv s) {fiUniq = u3}) (simpRemOccL s) (simpresRedGraph chrSimplifyResult) (simpEvidMp s) ; modify (\s -> s {simpRemCnstrTraceMp = chrSolveRemCnstrTraceMp, simpEvidMp = chrSolveEvidMp}) } else modify (\s -> s {simpRemCnstrTraceMp = Map.empty, simpRemOccL = []}) ; return () } where canon s c = case cnstrReducablePart c of Just (_,p,mkc) -> (mkc $ p {cpoPr = p'}, m) where (p',m) = predCanonic (emptyTyBetaRedEnv {tbredFI=simpEnv s}) $ cpoPr p _ -> (c, emptyVarMp) -- basic simplification of reduction graph basicSimpRedGraph chrSolveAllCnstrMp = do { s <- get ; let -- RedGraph to Evidence ((chrSolveRemCnstrTraceMp,chrSolveEvidMp,errs),chrSimplifyResult2) = chrSimplifyRedGraphToEvidence heur chrSolveAllCnstrMp (simpRes s) -- split unresolved into those who can be resolved by assuming them (via qualified types) and the others (chrSolveAssumablePrOccL,cannotResCnstrTraceMp) = partitionUnresolved2AssumableAndOthers chrSolveRemCnstrTraceMp -- TBD: propagation of unresolved traces for error reporting -- cannotResCnstrMp = cnstrTraceMpElimTrace cannotResCnstrTraceMp -- chrSolveRemCnstrMp = cnstrTraceMpElimTrace chrSolveRemCnstrTraceMp ; put (s {simpRemCnstrTraceMp = chrSolveRemCnstrTraceMp, simpEvidMp = chrSolveEvidMp, simpErrs = errs, simpRes = chrSimplifyResult2}) ; return (cannotResCnstrTraceMp,chrSolveAssumablePrOccL) } -- full simplification fullSimp u toProveHereCnstrMpPrev chrSimplifyResult = do { s <- get ; let -- simplification, to RedGraph (chrSolveAllCnstrMp,chrSimplifyResult1) = chrSimplifySolveToRedGraph ((simpEnv s) {fiUniq = u}) chrStore toProveHereCnstrMpPrev (simpToProveHereCnstrMp s) chrSimplifyResult ; put (s {simpRes = chrSimplifyResult1, simpAllCnstrMp = chrSolveAllCnstrMp}) -- RedGraph to Evidence etc ; basicSimpRedGraph chrSolveAllCnstrMp } simplify :: [SimplifyHow] -- config -> FIIn -- environment -> CHRStore -- available CHR rules -> ClassDefaultGam -- environment/gam for defaulting -> Heuristic -- graph reduction heuristic -> ([CHRIntermediateUntilAssume] -> ([CHRIntermediateUntilAssume],[CHRIntermediateUntilAssume])) -- partition into ambiguous predicates (and others), for defaulting -> ConstraintToInfoMap -- constraints already proven a previous call -> ConstraintToInfoMap -- constraints to prove -> SimplifyResult -- simplification work done at a previous call -> ( ConstraintToInfoMap -- canonicalized to be proven constraints , ConstraintToInfoTraceMp -- remaining to be proven, as Assume's , ConstraintToInfoTraceMp -- cannot be proven , VarMp -- additional substitution found during proving & simplification , [Err] -- errors , SimplifyResult -- simplification work, for a next call , InfoToEvidenceMap -- map from constraint/pred occurrence to evidence , EvidCBindL -- bindings which can be directly inserted , EvidKeyToCBindMap -- map from occurrence to binding, globally , PredScopeToCBindMap -- map from predscope to binding, per predscope opening/intro , EvidKeyToCExprMap -- map from occurrence to expr + additional nesting info, for debug only ) simplify simplifyHow env chrStore clDfGam heur partitionUnresolved2AmbigAndOthers toProveHereCnstrMpPrev toProveHereCnstrMp prevRes = {- Debug.tr "simplify" ( (if toProveHereCnstrMpCanon == toProveHereCnstrMpCanon' then empty else pp "toProveHereCnstrMpCanon wrong") >-< (if canonVarMp == canonVarMp' then empty else pp "canonVarMp wrong") >-< (if cannotResCnstrMp1 == cannotResCnstrMp1' then empty else pp "cannotResCnstrMp1 wrong") >-< (if chrSolveRemCnstrMp3 == chrSolveRemCnstrMp3' then empty else pp "chrSolveRemCnstrMp3 wrong" >-< show chrSolveRemCnstrMp3 >-< show chrSolveRemCnstrMp3') -- >-< (if chrSolveAssumablePrOccL3 == chrSolveAssumablePrOccL3' then empty else pp "chrSolveAssumablePrOccL3 wrong" >-< ppCommas chrSolveAssumablePrOccL3 >-< ppCommas chrSolveAssumablePrOccL3') ) $ -} ( toProveHereCnstrMpCanon , chrSolveRemCnstrMp3, cannotResCnstrTraceMp , canonVarMp , firstNotEmpty [ chrSolveErrs2 , overlapErrs ] , chrSimplifyResult4 { simpresRemPredL = map fst chrSolveAssumablePrOccL3 } , chrSolveEvidMp2 , chrSolveEvidCBindL , chrSolveEvidBindMp, chrSolveScopeBindMp , chrSolveEvidCoreMp -- for debug only ) where opts = feEHCOpts $ fiEnv env s = execState (simplify' simplifyHow chrStore clDfGam heur partitionUnresolved2AmbigAndOthers toProveHereCnstrMpPrev) (emptySimplifyState {simpEnv = env {fiUniq = u1}, simpToProveHereCnstrMp = toProveHereCnstrMp, simpRes = prevRes}) env' = simpEnv s chrSimplifyResult4 = simpRes s chrSolveAssumablePrOccL3 = simpRemOccL s chrSolveRemCnstrMp3 = simpRemCnstrTraceMp s chrSolveEvidMp2 = simpEvidMp s chrSolveErrs2 = simpErrs s toProveHereCnstrMpCanon = simpToProveHereCnstrMp s canonVarMp = simpVarMp s cannotResCnstrTraceMp = simpCannotCnstrTraceMp s -- some unique seeds (_,u1,u2,u3) = mkNewLevUID3 $ fiUniq env -- (1) compute code (Core) for dictionaries/witness, (2) get the overlapping instances (chrSolveEvidCoreMp,overlapEvids) = evidMpToCore (env' {fiUniq = u3}) chrSolveEvidMp2 -- get the bindings which must be introduced (chrSolveEvidCBindL,chrSolveEvidBindMp,chrSolveScopeBindMp) = evidKeyCoreMpToBinds2 env' chrSolveEvidCoreMp -- overlapping errors; 20120209: is empty, detection done earlier -- overlapErrs = if null overlapEvids then [] else [rngLift range Err_OverlapPreds [ (cpoPr $ overlapevidPredOcc a,map pp $ overlapevidInfos a) | a <- overlapEvids]] overlapErrs = [] range = feRange $ fiEnv env -- debugging info -- dbgp = ppParensCommas $ Map.keys toProveHereCnstrMpCanon -- dbg m= id -- Debug.tr m dbgp fixedFtv mp = varFreeSet $ map cnstrPred $ Map.keys mp debugInfo chrSimplifyResult = (s,rg,chrSolveStateDoneConstraints s,chrSolveStateTrace s,redAlts,redTrees,simpresRemPredL chrSimplifyResult) where s = simpresSolveState chrSimplifyResult rg = simpresRedGraph chrSimplifyResult redAlts = simpresRedAlts chrSimplifyResult redTrees = simpresRedTrees chrSimplifyResult mkScopeBindings :: Bool -> PredScope -> PredScopeToCBindMap -> ([CBind],PredScopeToCBindMap) mkScopeBindings alsoOuter sc mp = (concatMap f scs,foldr Map.delete mp scs) where f sc = Map.findWithDefault [] sc mp scs = [sc] ++ (if alsoOuter then pscpParents sc else []) mkAssumeBindings :: [UID] -> EvidKeyToCBindMap -> [CBind] mkAssumeBindings ids mp = concat [ maybe [] id $ Map.lookup i mp | i <- ids ] type ScopeGam = Gam HsName PredScope -- | Get the superclass fields names tyPrLToSupNmL :: TyL -> [HsName] tyPrLToSupNmL = zipWith (\i p -> hsnUniqifyInt HsNameUniqifier_SuperClass i (tyPredNm p)) [1..] -- | Get dictionary type of predicate tyDict :: Ty -> Ty tyDict t = appConApp (hsnClass2Dict n) as where t' = predTy $ tyPred t n = tyAppFunConNm t' as = appUnAppArgs t' -- | given the name of an instance, return names of intermediate dictionaries being constructed mkInstanceBuildNms :: HsName -> (HsName,HsName) mkInstanceBuildNms dictNm = ( hsnUniqify HsNameUniqifier_ResultDict dictNm -- the computed result, being returned in the end , hsnUniqify HsNameUniqifier_SelfDict dictNm -- the default, partially built dictionary, given as argument ) -- | Get info about datatype and class for which derivation is done, looking up in various environments derivGetDataTyInfo :: HsName -> HsName -> TyGam -> TyKiGam -> DataGam -> (TyGamInfo,TyKiGamInfo,DataGamInfo,TyKiGamInfo,[Err]) derivGetDataTyInfo clNm tyNm tyGam tyKiGam dataGam = (tgi,tkgi,dgi,ctkgi,firstNotEmpty [errs123,errs4]) where (tgi, tkgi, dgi, errs123) -- special case to detect records/tuples | hsnIsRec tyNm = ( emptyTGI, emptyTKGI , emptyDataGamInfo {dgiVariant = DataGamInfoVariant_Rec} , [] ) | otherwise = let (tgi, errs1) = tyGamLookupErr tyNm tyGam -- lookup for type (dgi, errs3) = dataGamLookupErr tyNm dataGam -- lookup for structure info (tkgi,errs2) = tyKiGamLookupByNameErr tyNm tyKiGam -- lookup for kind signature in (tgi, tkgi, dgi, firstNotEmpty [errs1,errs2,errs3]) (ctkgi,errs4) = tyKiGamLookupByNameErr (hsnClass2Kind clNm) tyKiGam -- lookup for class kind signature -- | make pred from kind and tvar mkDerivPredFromKi :: UID -> Int -> Ty -> Ty -> Ty -> Maybe (Ty,UID) mkDerivPredFromKi uniq derivArity predTyCon ki tv = case appUnArr ki of (as,_) -- (as,Ty_Con n) | n == hsnKindStar -- ???? is this restriction indeed necessary? -> Just (mkTyPr $ Pred_Class $ predTyCon `appTopApp1` appTopApp (tv : map mkTyVar u1s),u') where (u',u1) = mkNewLevUID uniq u1s = mkNewUIDL arity u1 arity = length as - derivArity -- _ -> Nothing -- | make context from the kinds of the datatype args and the actual datatype args mkDerivPredContext :: UID -> Int -> Ty -> [Ty] -> [Ty] -> Maybe ([Ty],UID) mkDerivPredContext uniq derivArity predTyCon dataTyKiL dataTyArgL = foldr (\(k,t) cxu -> do (cx,u) <- cxu (cx',u') <- mkDerivPredFromKi u derivArity predTyCon k t return (cx' : cx, u') ) (Just ([],uniq)) (zip dataTyKiL dataTyArgL) mkWeaveExpr :: EHCOpts -> UID -> VarMp -> CSubst -> (CExpr->CExpr) -> CExpr -> [Coe] -> [Coe] -> (CExpr,CSubst) mkWeaveExpr opts uniq finTyVarMp csubst postmk expr lCoeL rCoeL = (postmk e, s1 `cSubstApp` s2) where (_,u1,u2) = mkNewLevUID2 uniq (ww,s1) = coeWipeWeaveAsSubst2 opts u1 finTyVarMp csubst lCoeL rCoeL (e ,s2) = coeEvalOnAsSubst u2 ww expr -- | Make bindings for constructors, given various bits of info mkDataConCBindL :: EHCOpts -> ToSysfEnv -> CTag -> Ty -> [DataConFldAnnInfo] -> HsName -> Bool -> [CBind] mkDataConCBindL opts sysfEnv ctag ty annL conNm isNewtype | isNewtype = [ acoreBind1Ty conNm cty ({- TBD: see TyCore: cast -} acoreExprUnThunk $ acoreVar $ ehcOptBuiltin opts ehbnId) ] | otherwise = [ acoreBind1Ty conNm cty $ wrap $ acoreLamTy (zip nms $ map mkt $ appUnArrArgs ty) $ foldr (.) id mkStrict $ acoreApp tup $ map acoreVar nms' ] where arity | isNewtype = 1 | otherwise = ctagArity ctag nms = (map (\i -> hsnFromString ("x" ++ show i)) [1 .. arity]) (nms',mkStrict) = (nms, replicate arity id) mkt = SysF.ty2TyC opts sysfEnv cty = mkt ty wrap = id tup = CExpr_Tup ctag -- | Generate all bindings given functions to generate individual bindings. mkDataBinds :: (Bool -> DataGamInfo -> [bind]) -- construct ty bind -> (Bool -> DataTagInfo -> [bind]) -- construct val bind -> DataGam -> ( [bind] -- ty bind , [bind] -- val bind ) mkDataBinds mkTy mkCon dataGam = ( concat [ mkTy (dgiIsNewtype dgi) dgi | dgi <- gamElts dataGam ] , concat [ concat [ mkCon (dgiIsNewtype dgi) dti | dti <- Map.elems constrMp ] | dgi@(DataGamInfo { dgiConstrTagMp = constrMp }) <- gamElts dataGam ] ) fsL2PatOffsetL :: EHCOpts -> FieldSplitL -> AssocL RPatFld (Maybe Int) fsL2PatOffsetL opts l = [ (RPatFld_Fld n oe n p,Just oi) | (o,(foff,p)) <- zip [0..] l, let (oi,oe) = foffMkOff opts foff o, let n = foffLabel foff ] -- | Combine bindings and extract main binding mkLetCBodyBindL :: Bool -> CBindCateg -> [(CBindCateg,CBindL)] -> [(CBindCateg,CBindL)] -> [(CBindCateg,CBindL)] -> CExpr -> ( [(CBindCateg,CBindL)] -- all remaining let bindings not bound in body , CBindL -- if non empty singleton list it holds the def for main , CExpr -- bound bindings together with body ) mkLetCBodyBindL isStrict howToBind locBindL locOthBindL bodyBindL body | isStrict = ( locOthBindL , locMainBindL , foldr (\(c,b) e -> acoreLet c b e) body (merge $ locNoMainBindL ++ bodyBindL) ) | otherwise = ( merge $ locOthBindL ++ locNoMainBindL ++ bodyBindL , locMainBindL , body ) where (locMainBindL, locNoMainBindL) = split locBindL where split ((c,g):bs) = (m ++ mbs, (c,nm) : nmbs) where (m ,nm ) = partition (\b -> cbindNm b == hsnMain) g (mbs,nmbs) = split bs split [] = ([], []) merge (cb1@(c1,b1) : tl) = case merge tl of (c2,b2) : tl' | c1 == c2 && c1 == CBindCateg_Rec -> (c1,b1++b2) : tl' tl' -> cb1 : tl' merge [] = [] cdictOffset :: HsName -> Ty -> Int cdictOffset n r = tyRecOffset n $ r -- | Make the various names required for instance building mkInstanceNames :: EHCOpts -> ToSysfEnv -> HsName -> Ty -> ( AssocL HsName (Ty,CTy) , [HsName] , [HsName] , [CExpr] ) mkInstanceNames opts sysfEnv dictNm instanceRecTy = ([(n,(t,SysF.ty2TyC opts sysfEnv t)) | (n,t) <- instanceFieldL],memberNames,memberNewNames,memberNewVars) where instanceFieldL = rowCanonOrder $ snd $ tyRecExts instanceRecTy memberNames = assocLKeys instanceFieldL memberNewNames = [ hsnUniqifyStr HsNameUniqifier_DictField (show n) dictNm | n <- memberNames ] memberNewVars = map acoreVar memberNewNames -- | Make a dictionary corresponding to an instance declaration mkNormalInstance :: EHCOpts -> ToSysfEnv -- environmental info for SysF stuff -> ClGamInfo -- info about the class -> DataGam -- env/gamma for datas -> CTag -- tag of the dictionary (as data type) -> (HsName,HsName,HsName) -- various names for the dictionary under construction at various stages of construction, also used externally -> CTy -- instance dict as data type -> Ty -- instance dict as record -> ( [HsName] -- names of super class fields , [HsName] -- names of super class dicts, given as arg , [HsName] -- names of context class dicts, given as arg ) -> [CBind] -- bindings for decls of the instance -> ([CBind] -- bindings for decls related context reduction, both Assume & Prove ,[CBind] -- bindings for super class related context reduction, only Prove ,[CBind] -- bindings for super + ctxt class related context reduction, only Assume ) -> ( CExpr -- the instance , () -- the meta info about the instance ) mkNormalInstance opts sysfEnv clgi dataGam dictTag (dictNm,_,dictBuildNm) instanceTy instanceRecTy (superFldNmL,superNmL,contextNmL) declsCBindL (chrDeclsCBindL,chrSuperProveCBindL,chrSuperCtxtAssumeCBindL) = ( bind4 , () ) where dfltNm = clgiDfltDictNm clgi rsltNm = dictBuildNm rsltNmStrict = hsnUniqifyEval rsltNm dfltNmStrict = hsnUniqifyEval dfltNm dfltVar = acoreVar dfltNm rsltVar = acoreVar rsltNm rsltVarStrict= acoreVar rsltNmStrict dfltVarStrict= acoreVar dfltNmStrict (instanceFieldL,memberNames,memberNewNames,memberNewVars) = mkInstanceNames opts sysfEnv dictNm instanceRecTy mkSetFlds = mkInstanceSetFlds opts dataGam dictTag instanceFieldL instanceRecTy -- mkCTy = SysF.ty2TyC opts sysfEnv instanceBindingPairs= [ (nm,v) | CBind_Bind nm asps <- declsCBindL, CBound_Bind v <- asps ] instanceMbBodies = map (flip lookup instanceBindingPairs) memberNames instanceMbNewNames = let f _ Nothing = Nothing f n (Just e) = Just n in zipWith f memberNewNames instanceMbBodies instanceMbNames = let f _ Nothing = Nothing f n (Just _) = Just n in zipWith f memberNames instanceMbNewNames instanceNameMapping = [ (nm, (), v) | (Just nm,v) <- zip instanceMbNames memberNewVars ] instanceNewBindings = [ acoreBind1Ty nm (acoreTyErr $ "EH.ToCore.mkNormalInstance.instanceNewBindings: " ++ show nm) v | (nm,Just v) <- zip memberNewNames instanceMbBodies ] superNewVars = map acoreVar superNmL superNameMapping = zip3 superFldNmL (repeat ()) superNewVars superNameMapping2 = zip superFldNmL superNmL superPairs = map getBindLeftAndRightVar chrSuperProveCBindL doubleLookup :: HsName -> Maybe HsName doubleLookup nm = do { nm2 <- lookup nm superNameMapping2 -- ; nm3 <- lookup nm2 superPairs ; return nm2 -- nm3 } superMbNewNames = map doubleLookup memberNames instanceAndSuperMbNewNames = let f (Just x) _ = Just x f _ (Just y) = Just y f _ _ = Nothing in zipWith f instanceMbNewNames superMbNewNames instanceAndSuperTracks = map mbNameToTrack instanceAndSuperMbNewNames instanceCHRBindings = chrSuperCtxtAssumeCBindL ++ chrSuperProveCBindL ++ chrDeclsCBindL dict1 = acore1App dfltVar rsltVar bind1 = acoreBind1Ty dfltNmStrict instanceTy dict1 dict2 = acoreLetBase (acoreBindcategStrict) [bind1] (mkSetFlds (superNameMapping ++ instanceNameMapping) dfltVarStrict) bind2 = acoreBind1Ty rsltNmStrict instanceTy dict2 dict3 = acoreLetBase (acoreBindcategPlain) [bind2] rsltVarStrict bind3 = acoreBind1Ty rsltNm instanceTy dict3 dict4 = acoreLetRec ([bind3] ++ instanceNewBindings ++ instanceCHRBindings) rsltVar bind4 = acoreLamTy (acoreTyErrLift "EH.ToCore.mkNormalInstance.dict4" contextArguments) dict4 -- The above generates the following Core code as dict4: -- -- letrec reslt = let rsltStrict = let! dfltStrict = dflt rslt -- in case defltStrict of -- (Dict-C _1 _2 _3 _4) -> (Dict-C _1 inst2 _3 inst4) -- in this example, field 2 and 4 are defined in the isntance, 1 and 3 are taken from the defaultdefinitions -- in rsltStrict -- inst2 = ... -- inst4 = ... -- in reslt contextArguments = contextNmL -- Make a dictionary for a normal instance, the default-definitions of a class, or for a derived instance mkInstanceCBindL :: EHCOpts -> ToSysfEnv -- environmental info for SysF stuff -> ClGamInfo -- info about the class -> TyKiGam -- env/gamma for ki of ty's -> DataGam -- env/gamma for datas -> InstVariant -- what kind of instance -> CTag -- tag of the dictionary (as data type) -> (HsName,HsName,HsName) -- various names for the dictionary under construction at various stages of construction, also used externally -> Ty -- instance dict as data type -> Ty -- instance dict as record -> ( [HsName] -- names of super class fields , [HsName] -- names of super class dicts, given as arg , [HsName] -- names of context class dicts, given as arg ) -> [CBind] -- bindings for decls of the instance -> ([CBind] -- bindings for decls related context reduction, both Assume & Prove ,[CBind] -- bindings for super class related context reduction, only Prove ,[CBind] -- bindings for super + ctxt class related context reduction, only Assume ) -> [CBind] mkInstanceCBindL opts sysfEnv clgi tyKiGam dataGam instVariant dictTag nms@(dictNm,dictSelfNm,dictBuildNm) instanceTy instanceRecTy nmLs@(superFldNmL,superNmL,contextNmL) declsCBindL chrBindLs@(chrDeclsCBindL,chrSuperProveCBindL,chrSuperCtxtAssumeCBindL) = [acoreBind1Ty dictNm instanceCTy generatedDictionary] where (generatedDictionary, _ {- generatedMeta -}) = case instVariant of InstNormal -> mkNormalD declsCBindL InstDefault -> mkDefaultD declsCBindL InstDeriving _ -> mkNormalD declsCBindL rsltNm = dictBuildNm rsltVar = acoreVar rsltNm instanceCTy = SysF.ty2TyC opts sysfEnv instanceTy mkNormalD instanceBindings = mkNormalInstance opts sysfEnv clgi dataGam dictTag nms instanceCTy instanceRecTy nmLs instanceBindings chrBindLs -- Make a dictionary corresponding to (the default definitions in a) class definition mkDefaultD defaultBindings = let selfNm = dictSelfNm (instanceFieldL,memberNames,memberNewNames,memberNewVars) = mkInstanceNames opts sysfEnv dictNm instanceRecTy -- lookupMeta n = if n `elem` superFldNmL then () else () defaultBindingPairs = [ (nm,v) | CBind_Bind nm asps <- defaultBindings, CBound_Bind v <- asps ] defaultMbBodies = map (flip lookup defaultBindingPairs) memberNames -- defaultMetas = map lookupMeta memberNames defaultBodies = map (maybe (acoreBuiltinUndefined opts) id) defaultMbBodies defaultMbNewNames = let f _ Nothing = Nothing f n (Just _) = Just n in zipWith f memberNewNames defaultMbBodies -- defaultTracks = map mbNameToTrack defaultMbNewNames defaultNewBindings = zipWith (\n b -> acoreBind1Ty n (acoreTyErr $ "EH.ToCore.mkInstanceCBindL.defaultNewBindings: " ++ show n) b) memberNewNames defaultBodies defaultCHRBindings = chrDeclsCBindL dict5 = acoreTagTupTy dictTag (acoreTyErr "EH.ToCore.mkInstanceCBindL.dict5") memberNewVars -- acoreApp (CExpr_Tup dictTag) memberNewVars bind5 = acoreBind1Ty rsltNm (acoreTyErr $ "EH.ToCore.mkInstanceCBindL.bind5: " ++ show rsltNm) dict5 dict6 = acoreLetRec ([bind5] ++ defaultNewBindings ++ defaultCHRBindings) rsltVar bind6 = acoreLam1Ty selfNm (acoreTyErr $ "EH.ToCore.mkInstanceCBindL.bind6: " ++ show selfNm) dict6 in ( bind6 , () ) mkInstanceSetFlds :: EHCOpts -> DataGam -> CTag -> AssocL HsName (Ty,CTy) -> Ty -> [(HsName,(),CExpr)] -> CExpr -> CExpr mkInstanceSetFlds opts dataGam dictTag instanceFieldL instanceRecTy = if ehcCfgClassViaRec opts then mkSetFldsRec else mkSetFldsData where off n = cdictOffset n instanceRecTy off' n = tyExtsOffset n instanceFieldL mkSetFldsRec ts d0 = foldl (\d (n,_,v) -> mkSet d n v) d0 ts where mkSet d n v = CExpr_TupUpd d dictTag n (acoreInt opts $ off n) v mkSetFldsData ts d0 = acoreSatSelsCaseTy env Nothing d0 dictTag nmLblOffL Nothing sel where env = (emptyRCEEnv opts) {rceDataGam = dataGam} fullListWithTrivialValues = [ (o, (o, t, acoreVar n)) | (n,t,o) <- nmLblOffL ] sparseListWithInterestingValues = [ (o, maybe (acoreTyErr $ "mkInstanceSetFlds.sparseListWithInterestingValues: " ++ show n) snd mbt, v) | (n,m,v) <- ts, let ((o,_),mbt) = off' n ] arity = ctagArity dictTag ns = take arity hsnLclSupply nmLblOffL :: [(HsName,CTy,Int)] nmLblOffL = zipWith3 (\n (_,(_,t)) o -> (n,t,o)) ns instanceFieldL [0..] sel = acoreTagTupTy dictTag (acoreTyErr "mkInstanceSetFlds.sel") -- acoreApp (CExpr_Tup dictTag) (map (\(_,_,v) -> v) $ listSaturateWith 0 (arity-1) (\(o,_,_) -> o) fullListWithTrivialValues sparseListWithInterestingValues ) getBindRightVar :: CBind -> Maybe HsName getBindRightVar (CBind_Bind _ [CBound_Bind v]) = acoreExprMbVar v getBindRightVar _ = Nothing getBindLeftAndRightVar :: CBind -> (HsName,HsName) getBindLeftAndRightVar (CBind_Bind nm1 [CBound_Bind (CExpr_Var ref2)]) = (nm1, acbrefNm ref2) getBindLeftAndRightVar _ = error "getBindLeftAndRightVar: not a bind" mbNameToTrack Nothing = TrackNone mbNameToTrack (Just nm) = TrackVarApply nm [] mkInstanceDerivingFldBind :: EHCOpts -> RCEEnv -> DataGam -> UID -> DataGamInfo -> Ty -> HsName -> CTag -> [[PredOcc]] -> [PredOcc] -> DerivClsFld -> CBind mkInstanceDerivingFldBind opts rceEnv dataGam uniq derivDataDGI derivHdDataTy dictBuildNm ctag derivAltsPrOcc derivExtraPrOcc = mkf where rsltNm = dictBuildNm rsltVar = acoreVar rsltNm mkf :: DerivClsFld -> CBind mkf dcf = acoreBind1Ty (dcfNm dcf) (acoreTyErr $ "EH.ToCore.mkInstanceDerivingFldBind.mkf.dcfNm: " ++ show (dcfNm dcf)) (if fArity == 0 then acoreLamTy (acoreTyErrLift "EH.ToCore.mkInstanceDerivingFldBind.mkf.A" $ dcfInitialArgL dcf) $ dcfNoArgSubsCExpr dcf rceEnv [ (dti,mkcSubs dti (repeat []) altPrOccL) | (dti,altPrOccL) <- zip dtis derivAltsPrOcc ] nrOfAlts rsltVar extraCxL (dcfInitialArgL dcf) else acoreLamTy (acoreTyErrLift "EH.ToCore.mkInstanceDerivingFldBind.mkf.B" $ dcfInitialArgL dcf ++ take fArity nsA) (dcfWrapCase dcf opts derivDataDGI nrOfAlts n1 (dcfInitialArgL dcf) $ acoreStrictSatCaseTy rceEnv (Just (hsnUniqifyEval n1,(acoreTyErr $ "EH.ToCore.mkInstanceDerivingFldBind.mkf.n1: " ++ show n1))) n1v [ CAlt_Alt (dcfMkCPat dcf altInx ctag (ctagArity ctag) (Just $ n1subs ctag)) (mkc splDTI altInx (fArity - 1) n1s [n1subs ctag] altPrOccL) | (ctag,altPrOccL) <- zip (map dtiCTag dtis) derivAltsPrOcc , let splDTI@(dtisLT,_,_) = splitDTIs ctag dtis altInx = length dtisLT ] ) ) where n1v = acoreVar n1 nsA@(n1:n1s) = hsnLclSupplyWith (mkHNm "x") dtis = panicJust "Decl.Instance.Deriving.dataGamDTIsOfTy" $ dataGamDTIsOfTy derivHdDataTy dataGam nrOfAlts = length dtis splitDTIs t ts -- in (lt,eq,gt), according to list ordering = (l,e,g) where (l,(e:g)) = span ((/= t) . dtiCTag) ts fArity = (length $ appUnArrArgs $ dcfTy dcf) - dcfNrOmitTailArg dcf - length (dcfInitialArgL dcf) - 1 {- dictionary -} n1subs t = nsubs t n1 nsubs t n = take (ctagArity t) $ hsnLclSupplyWith n extraCxL = [ acoreNmHolePred (poPoi prOcc) | prOcc <- derivExtraPrOcc ] mkcSubs dti nmFldLL altPrOccL = [ acoreApp (acoreVar (dcfNm dcf)) ([acoreNmHolePred (poPoi prOcc)] ++ (dcfInitialSubArgL dcf dti ++ map acoreVar nmFldL)) | (nmFldL,prOcc) <- zip nmFldLL altPrOccL ] mkc tg@(dtisLT,dti,dtisGT) altInx arity nms nmFldLL altPrOccL = case nms of (n:ns) | arity > 0 -> acoreStrictSatCaseTy rceEnv (Just (hsnUniqifyEval n,(acoreTyErr $ "EH.ToCore.mkInstanceDerivingFldBind.mkf.mkc.n: " ++ show n))) (acoreVar n) ( [ mka (dtiCTag dti) tsubs (mkc tg altInx (arity - 1) ns (nmFldLL ++ [tsubs]) altPrOccL) ] ++ [ mka t (nsubs t n) (dcfAllTagLtCExpr dcf) | t <- map dtiCTag dtisLT ] ++ [ mka t (nsubs t n) (dcfAllTagGtCExpr dcf) | t <- map dtiCTag dtisGT ] ) where tsubs = nsubs (dtiCTag dti) n mka ctag nsubs e = CAlt_Alt (dcfMkCPat dcf altInx ctag (ctagArity ctag) (Just nsubs)) e _ -> dcfFoldSubsCExpr dcf uniq rceEnv dti (altInx, nrOfAlts) (dcfInitialArgL dcf) $ mkcSubs dti (transpose nmFldLL) altPrOccL mkDataGenerBinds :: -- (AbstractCore e m b bcat mbind t) => EHCOpts -> ToSysfEnv -> RCEEnv -> ClGam -- env/gamma for class -> TyKiGam -- env/gamma for ki of ty's -> DataGam -- env/gamma for datas -> UID -- uniq -> [GenerDataInstInfo] -- inst infos -> ([CBind],[Err]) mkDataGenerBinds opts sysfEnv rceEnv clGam tyKiGam dataGam uniq instInfoL = (concat instBinds, concat errs) where (instBinds,errs) = unzip $ map mk instInfoL mk (orignm,dictNm,clNm,instKind,pr) = ( mkInstanceCBindL opts sysfEnv clgi tyKiGam dataGam InstNormal (clgiDictTag clgi) (dictNm,dictSelfNm,dictBuildNm) (pred2DataTy pr) recTy ([],[],[]) binds ([],[],[]) , foErrL evFO ) where (_,u1,u2) = mkNewLevUID2 uniq clgi = panicJust ("mkDataGenerBinds.clGam: " ++ show dictNm ++ " :: class " ++ show clNm) $ gamLookup clNm clGam -- derived names required for building (dictSelfNm,dictBuildNm) = mkInstanceBuildNms dictNm -- match predicate to get the record type describing fields of dictionary evFO = fitPredToEvid' u1 emptyVarMp (mkTyPr pr) (Left clgi) recTy = foVarMp evFO `varUpd` foTy evFO -- the bindings for datatypes acting as labels binds = case instKind of GenerInstKind_Representable remArity proj -> [ acoreBind1 (ehcOptBuiltin2 opts ehbnGenerClassRepresentableNFldFrom remArity) (projFrom opts rceEnv proj) , acoreBind1 (ehcOptBuiltin2 opts ehbnGenerClassRepresentableNFldTo remArity) (projTo opts rceEnv proj) ] GenerInstKind_Datatype -> [ mkBindStr ehbnGenerClassDatatypeFldName $ hsnQualified orignm , mkBindStr ehbnGenerClassDatatypeFldModule $ maybe hsnUnknown id $ hsnQualifier orignm ] GenerInstKind_Selector -> [ mkBindStr ehbnGenerClassSelectorFldName $ hsnQualified orignm ] GenerInstKind_Constructor tyNm -> [ mkBindStr ehbnGenerClassConstructorFldName $ hsnQualified orignm ] ++ (if Map.null (dtiFldMp dti) then [] else [mkBind ehbnGenerClassConstructorFldIsRec $ acoreVar $ biNm ehbnBoolTrue]) ++ (if isNothing mbInfix then [] else [mkBind ehbnGenerClassConstructorFldFixity $ acoreApp (acoreVar $ biNm ehbnGenerDataFixityAltInfix) $ [ acoreVar (biNm (case fixity of Fixity_Infix -> ehbnGenerDataAssociativityAltNot Fixity_Infixr -> ehbnGenerDataAssociativityAltRight Fixity_Infixl -> ehbnGenerDataAssociativityAltLeft ) ) , acoreInt opts prio ] ] ) where dgi = panicJust ("mkDataGenerBinds.dataGam: " ++ show tyNm) $ dataGamLookup tyNm dataGam dti = panicJust ("mkDataGenerBinds.dgiConstrTagMp: " ++ show orignm) $ Map.lookup orignm $ dgiConstrTagMp dgi mbInfix@(~(Just (prio,fixity))) = dtiMbFixityPrio dti -- _ -> [] -- get a builtin name biNm = ehcOptBuiltin opts -- utils for bindings argNm = mkHNm "x" mkBindx a f x = acoreBind1 (biNm f) (acoreLamTy (acoreTyErrLift "mkDataGenerBinds.mkBindx" [a]) x) mkBind = mkBindx argNm mkBindStr f n = mkBind f $ acoreBuiltinString opts $ show n -- | Construct type representations for constructing and deconstructing a constructor mkDataConstrTys1 :: (TyL,FldTyL) -> Ty -> (Ty, Ty) mkDataConstrTys1 (dataConTyL,dataConFldTyL) dataTy = (dataConTy, dataConProdTy) where dataConTy = dataConTyL `appArr` dataTy dataConProdTy = recRec $ assocLMapKey fromJust $ fldTyLEnsureLabels dataConFldTyL -- | Construct type representations for constructing and deconstructing a constructor mkDataConstrTys2 :: (TyVarId -> Ty) -> Ty -> Ty -> Ty mkDataConstrTys2 (mkMetaTy) dataConProdTy dataTy = dataQuUnConTy where dataConTyFv = varFree dataTy dataConProdTyFv = varFree dataConProdTy dataQuUnConTy = [dataTy] `appArr` mkTyQu tyQu_Exists (mkk (dataConProdTyFv \\ dataConTyFv)) dataConProdTy where mkk tvs = [ (v, mkMetaTy v) | v <- tvs ] -- zip tvs (repeat kiStar) -- TBD mkDataConstrValGam :: HsName -> Ty -> Ty -> ValGam mkDataConstrValGam conNm dataConTy dataQuUnConTy = assocLToGam [ (conNm, ValGamInfo dataConTy), (hsnUn conNm, ValGamInfo dataQuUnConTy) ] -- | Construct a kind type for a existentially quantified tyvar in the deconstructor of a datatype -- mkDataConstrTyVarKi :: TyKiGam -> TyKiGam -> VarMp -> TyVarId -> Ty -- mkDataConstrTyVarKi finTyKiGam intlTyKiGam tvKiVarMp = tvarKi finTyKiGam intlTyKiGam tvKiVarMp emptyVarMp infixr 2 >###< -- same as >-< (>###<) :: PP_Doc -> PP_Doc -> PP_Doc l >###< r = l >-< indent 2 r checkClNms :: Range -> HsNameS -> [Err] checkClNms r s = if Set.null s then [] else [mkErr_NamesNotIntrod r "class" (Set.toList s)] mkRangedPred :: RangeMp -> Pred -> (Pred,[Range]) mkRangedPred rm pr = (pr,Map.findWithDefault [] pr rm) mkPrvErr :: RangeMp -> Range -> ConstraintToInfoTraceMp -> [Err] mkPrvErr rm r m = if Map.null m then [] else [Err_NotProvenPreds r [ (mkRangedPred rm pr, vlist $ map pp t) | (c,((_,t):_)) <- Map.toList m, let pr = cpoPr (cnstrPred c) ]] gamErrToL :: Range -> Gam HsName ErrL -> ErrL gamErrToL r = concat . map (\(n,e) -> mkNestErr r (pp n) e) . gamToAssocL ppErrsSq :: ErrSq -> PP_Doc ppErrsSq = ppErrs . Seq.toList tyGamLookupOrAdd :: UID -> HsName -> TyGam -> TyGam -> (TyGamInfo,TyGam) tyGamLookupOrAdd uniq nm tyGamLkup tyGam = case tyGamLookup nm tyGamLkup of Nothing -> let t = mkNewTyVar uniq tgi = mkTGI t in (tgi,gamAdd nm tgi tyGam) Just tgi -> (tgi,tyGam) tyKiGamLookupOrAdd :: UID -> Ty -> TyKiGam -> (TyKiGamInfo,TyKiGam,TyKiGam) tyKiGamLookupOrAdd uniq t tyKiGam = case tyKiGamLookup t tyKiGam of Nothing -> (tkgi, newg `gamUnion` tyKiGam, newg) where tkgi = TyKiGamInfo (mkNewTyVar uniq) -- t newg = tyKiGamSingleton t tkgi Just tkgi -> (tkgi,tyKiGam,emptyGam) tvGathFlowOut :: Ord k => Gam k v -> Gam k v -> Gam k v tvGathFlowOut lhsG insideG = lhsG' where (l,g) = gamPop insideG lhsG' = gamAddGam l lhsG tvGathFlowIn :: Ord k => Gam k v -> Gam k v -> Gam k v tvGathFlowIn newG lhsG = gamPushNew (gamPushGam newG lhsG) type DoFit = FIOpts -> VarMp -> FIOut mkFreshAppImTy :: UID -> (Ty -> Ty) -> (Ty,Ty,Ty) mkFreshAppImTy u mkr = (im,rt,[im] `appArr` rt) where [i,r] = mkNewUIDL 2 u im = mkImplsVar i rt = mkr $ mkTyVar r mkFreshLamImTy :: UID -> (Ty,Ty,Ty,Ty) mkFreshLamImTy u = (im,at,rt,[im,at] `appArr` rt) where [i,a,r] = mkNewUIDL 3 u im = mkImplsVar i at = mkTyVar a rt = mkTyVar r dfCheck :: UID -> FIOpts -> FIEnv -> HsName -> ValGam -> VarMp -> Ty -> (Ty,Ty,Ty,FIOut,[Err]) dfCheck uniq fiOpts fe fldNm valGam knTyVarMp knTy = (gTy,knDataTy,knFldTy,fo,nmErrs) where (gTy,nmErrs) = valGamLookupTy (hsnFldUpd fldNm) valGam (_,u1,u2) = mkNewLevUID2 uniq (knFldTy,knDataTy,knFldUpdTy) = (e,df,v `appArr` knTy) where v@[e,df] = mkNewTyVarL 2 u1 fo = fitsIn fiOpts fe u2 knTyVarMp gTy knFldUpdTy -- | Construct a function which does quantification given some fixed environmental info mkDoValGamQuantify :: TyKiGam -> VarMp -> TyVarIdS -> ValGam -> (Bool -> VarMp -> [PredOcc] -> (ValGam, VarMp, (VarMp, TQOGam))) mkDoValGamQuantify valQuTyKiGam quTvKiVarMp noLetQuantTyVarIdS valGam_l_ = \doQuant tyVarMp prOccL -> valGamQuantifyWithVarMp doQuant valQuTyKiGam quTvKiVarMp tyVarMp noLetQuantTyVarIdS prOccL valGam_l_ -- | split a list of predicates into non-ambiguous & ambiguous, using quantifications results tqoGam, -- which (a.o.) administers which predicates could be merged for quantification, those not are then ambiguous doPredAmbigSplit :: (x -> PredOcc) -> TQOGam -> [x] -> ([x],[x]) doPredAmbigSplit get tqoGam prOccL = partition (\o -> poPoi (get o) `Set.member` assumedByQuant) prOccL where assumedByQuant = Set.unions $ map tmpoInsPrIdSet $ gamElts tqoGam -- | Split predicates according to whether the predicate combining part of quantification can be done mkDoPredAmbigSplitForSimplify :: (Bool -> vm -> [PredOcc] -> (dum1,dum2,(dum3,TQOGam))) -> vm -> [(CHRPredOcc, x)] -> ([(CHRPredOcc, x)],[(CHRPredOcc, x)]) mkDoPredAmbigSplitForSimplify doValGamQuantify tyVarMpDeclsL01 = \chrPrOccL -> let us = mkNewLevUIDL (length chrPrOccL) uidStart -- couple with arbitrary id's to make quantify & split work prOccL = zipWith (\u (o,_) -> cpo2PredOcc (mkPrId u) o) us chrPrOccL (_,_, (_,tqoGam)) = doValGamQuantify False tyVarMpDeclsL01 prOccL (namb,amb) = doPredAmbigSplit fst tqoGam $ zip prOccL chrPrOccL in (map snd amb, map snd namb) type RangeMp = Map.Map Pred [Range] cnstrMpToRangeMp :: ConstraintToInfoMap -> RangeMp cnstrMpToRangeMp m = Map.unionsWith (++) [ Map.singleton (cpoPr p) [cpoRange p] | (Prove p) <- Map.keys m ] data ExprCtxt = ExprCtxt_Top | ExprCtxt_Lam | ExprCtxt_Internal deriving Eq -- AGItf ------------------------------------------------------- -- semantic domain type T_AGItf = CHRStore -> ClassDefaultGam -> ClGam -> DataGam -> UID -> IdQualGam -> ImportUsedModules -> Bool -> KiGam -> ModuleImportExportImpl -> HsName -> EHCOpts -> PolGam -> TyGam -> TyKiGam -> ValGam -> ( ErrSq,CModule,UID,CHRStore,ClassDefaultGam,ClGam,DataGam,(Seq.Seq (HsName,IdOccKind)),KiGam,LamMp,ModEntRelFilterMp,PolGam,TyGam,TyKiGam,ValGam,(Maybe (Set.Set HsName)),PP_Doc,PP_Doc,PP_Doc,TrPP) -- CaseAlt ----------------------------------------------------- -- semantic domain type T_CaseAlt = ( Range,T_CaseAlt_1) type T_CaseAlt_1 = UID -> ( UID,T_CaseAlt_2) type T_CaseAlt_2 = KiGam -> Int -> Int -> ( Int,T_CaseAlt_3) type T_CaseAlt_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,T_CaseAlt_4) type T_CaseAlt_4 = ClGam -> DataGam -> VarMp -> TyKiGam -> TyVarIdS -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),T_CaseAlt_5) type T_CaseAlt_5 = Ty -> VarMp -> ValGam -> ( VarMp,T_CaseAlt_6) type T_CaseAlt_6 = CHRStore -> ClassDefaultGam -> FIOpts -> Ty -> VarMp -> TyVarIdS -> VarMp -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,VarMp,T_CaseAlt_7) type T_CaseAlt_7 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,CSubst,ErrSq,ModEntRelFilterMp,VarMp,Ty,PP_Doc,PP_Doc,RAlt,RAlt,TrPP,Ty) -- CaseAlts ---------------------------------------------------- -- semantic domain type T_CaseAlts = ( Range,T_CaseAlts_1) type T_CaseAlts_1 = UID -> ( UID,T_CaseAlts_2) type T_CaseAlts_2 = KiGam -> Int -> Int -> ( Int,T_CaseAlts_3) type T_CaseAlts_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,T_CaseAlts_4) type T_CaseAlts_4 = ClGam -> DataGam -> VarMp -> TyKiGam -> TyVarIdS -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),T_CaseAlts_5) type T_CaseAlts_5 = Ty -> Ty -> VarMp -> ValGam -> ( VarMp,Ty,T_CaseAlts_6) type T_CaseAlts_6 = CHRStore -> ClassDefaultGam -> FIOpts -> VarMp -> TyVarIdS -> VarMp -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,VarMp,T_CaseAlts_7) type T_CaseAlts_7 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,CSubst,ErrSq,ModEntRelFilterMp,VarMp,Ty,PP_Doc,PP_Doc,([PP_Doc]),([RAlt]),([RAlt]),TrPP) -- DataConstr -------------------------------------------------- -- semantic domain type T_DataConstr = ( Range,T_DataConstr_1) type T_DataConstr_1 = UID -> ( UID,T_DataConstr_2) type T_DataConstr_2 = Ty -> Polarity -> PolGam -> VarMp -> TyGam -> ( (AssocL HsName Ty),Int,VarMp,T_DataConstr_3) type T_DataConstr_3 = Ty -> VarMp -> Int -> TyKiGam -> HsName -> ( Ty,([HsName]),DataConstrTagMp,TyKiGam,VarMp,T_DataConstr_4) type T_DataConstr_4 = TyKiGam -> VarMp -> ValGam -> VarMp -> ( ValGam,ValGam,ConstraintToInfoMap,RangeMp,VarMp,ValGam,T_DataConstr_5) type T_DataConstr_5 = EvidKeyToCBindMap -> PredScopeToCBindMap -> CHRStore -> ClassDefaultGam -> ClGam -> VarMp -> VarMp -> Bool -> KiGam -> Int -> HsName -> EHCOpts -> PredScope -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ValGam -> TyVarIdS -> ( ErrSq,ErrSq,CBindL,CBindL,ModEntRelFilterMp,VarMp,PP_Doc,PP_Doc,TrPP,CBindL,CBindL) -- DataConstrs ------------------------------------------------- -- semantic domain type T_DataConstrs = ( Range,T_DataConstrs_1) type T_DataConstrs_1 = UID -> ( UID,T_DataConstrs_2) type T_DataConstrs_2 = Ty -> Polarity -> PolGam -> VarMp -> TyGam -> ( (AssocL HsName Ty),Int,VarMp,T_DataConstrs_3) type T_DataConstrs_3 = Ty -> VarMp -> Int -> TyKiGam -> HsName -> ( Ty,([HsName]),DataConstrTagMp,TyKiGam,VarMp,T_DataConstrs_4) type T_DataConstrs_4 = TyKiGam -> VarMp -> ValGam -> VarMp -> ( ValGam,ValGam,ConstraintToInfoMap,RangeMp,VarMp,ValGam,T_DataConstrs_5) type T_DataConstrs_5 = EvidKeyToCBindMap -> PredScopeToCBindMap -> CHRStore -> ClassDefaultGam -> ClGam -> VarMp -> VarMp -> Bool -> KiGam -> Int -> HsName -> EHCOpts -> PredScope -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ValGam -> TyVarIdS -> ( ErrSq,ErrSq,CBindL,CBindL,ModEntRelFilterMp,VarMp,PP_Doc,PP_Doc,([PP_Doc]),TrPP,CBindL,CBindL) -- DataField --------------------------------------------------- -- semantic domain type T_DataField = ( Range,T_DataField_1) type T_DataField_1 = UID -> ( UID,T_DataField_2) type T_DataField_2 = Polarity -> PolGam -> VarMp -> TyGam -> ( ([DataConFldAnnInfo]),FldTyL,VarMp,TyGam,T_DataField_3) type T_DataField_3 = TyKiGam -> ( TyKiGam,TyKiGam,T_DataField_4) type T_DataField_4 = Ty -> VarMp -> ( ValGam,ValGam,ConstraintToInfoMap,RangeMp,TyL,VarMp,T_DataField_5) type T_DataField_5 = EvidKeyToCBindMap -> PredScopeToCBindMap -> CHRStore -> ClassDefaultGam -> ClGam -> VarMp -> TyKiGam -> VarMp -> KiGam -> Int -> HsName -> EHCOpts -> VarMp -> PredScope -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> VarMp -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,ModEntRelFilterMp,VarMp,VarMp,PP_Doc,PP_Doc,TrPP) -- DataFieldExpr ----------------------------------------------- -- semantic domain type T_DataFieldExpr = ( Range,T_DataFieldExpr_1) type T_DataFieldExpr_1 = UID -> ( UID,T_DataFieldExpr_2) type T_DataFieldExpr_2 = KiGam -> Int -> Int -> ( Int,T_DataFieldExpr_3) type T_DataFieldExpr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,T_DataFieldExpr_4) type T_DataFieldExpr_4 = ClGam -> VarMp -> TyKiGam -> DataGam -> TyVarIdS -> ( DataGam,T_DataFieldExpr_5) type T_DataFieldExpr_5 = DataGam -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),T_DataFieldExpr_6) type T_DataFieldExpr_6 = CHRStore -> ClassDefaultGam -> FIOpts -> VarMp -> TyVarIdS -> VarMp -> ValGam -> TyVarIdS -> ( ([HsName]),(Maybe HsName),Ty,VarMp,T_DataFieldExpr_7) type T_DataFieldExpr_7 = FIOpts -> Ty -> VarMp -> ( ConstraintToInfoMap,RangeMp,TyVarIdS,Ty,VarMp,T_DataFieldExpr_8) type T_DataFieldExpr_8 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> DataGamInfo -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,CSubst,CBindL,CExpr,ErrSq,(FieldUpdateL (DataTagInfo -> Int -> CExpr)),ModEntRelFilterMp,VarMp,(Maybe DataTagInfo),PP_Doc,PP_Doc,([PP_Doc]),TrPP) -- DataFieldPatExpr -------------------------------------------- -- semantic domain type T_DataFieldPatExpr = ( Range,T_DataFieldPatExpr_1) type T_DataFieldPatExpr_1 = UID -> ( UID,T_DataFieldPatExpr_2) type T_DataFieldPatExpr_2 = KiGam -> Int -> Int -> ( Int,T_DataFieldPatExpr_3) type T_DataFieldPatExpr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,TyGam,TyKiGam,T_DataFieldPatExpr_4) type T_DataFieldPatExpr_4 = ClGam -> DataGam -> VarMp -> TyKiGam -> TyVarIdS -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),T_DataFieldPatExpr_5) type T_DataFieldPatExpr_5 = FIOpts -> Ty -> VarMp -> ValGam -> ValGam -> ( VarMp,ValGam,T_DataFieldPatExpr_6) type T_DataFieldPatExpr_6 = CHRStore -> ClassDefaultGam -> VarMp -> TyVarIdS -> VarMp -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,ScopeGam,Ty,VarMp,T_DataFieldPatExpr_7) type T_DataFieldPatExpr_7 = CSubst -> HsName -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> VarMp -> ( ErrSq,CSubst,DataTagInfo,ErrSq,([HsName]),FieldSplitL,ModEntRelFilterMp,VarMp,CPatRest,PP_Doc,PP_Doc,([PP_Doc]),TrPP,CBindL) -- DataFields -------------------------------------------------- -- semantic domain type T_DataFields = ( Range,T_DataFields_1) type T_DataFields_1 = UID -> ( UID,T_DataFields_2) type T_DataFields_2 = Polarity -> PolGam -> VarMp -> TyGam -> ( ([DataConFldAnnInfo]),FldTyL,VarMp,TyGam,T_DataFields_3) type T_DataFields_3 = TyKiGam -> ( TyKiGam,TyKiGam,T_DataFields_4) type T_DataFields_4 = Ty -> VarMp -> ( ValGam,ValGam,ConstraintToInfoMap,RangeMp,TyL,VarMp,T_DataFields_5) type T_DataFields_5 = EvidKeyToCBindMap -> PredScopeToCBindMap -> CHRStore -> ClassDefaultGam -> ClGam -> VarMp -> TyKiGam -> VarMp -> KiGam -> Int -> HsName -> EHCOpts -> VarMp -> PredScope -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> VarMp -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,ModEntRelFilterMp,VarMp,VarMp,PP_Doc,PP_Doc,([PP_Doc]),TrPP) -- Decl -------------------------------------------------------- -- semantic domain type T_Decl = ( Range,T_Decl_1) type T_Decl_1 = UID -> TyGam -> ( UID,TyGam,Bool,T_Decl_2) type T_Decl_2 = KiGam -> ( TyKiGam,T_Decl_3) type T_Decl_3 = Int -> Int -> ( Int,T_Decl_4) type T_Decl_4 = TyGam -> TyKiGam -> ( TyGam,T_Decl_5) type T_Decl_5 = TyKiGam -> TyGam -> VarMp -> ( TyKiGam,VarMp,T_Decl_6) type T_Decl_6 = VarMp -> PolGam -> TyKiGam -> ( VarMp,PolGam,T_Decl_7) type T_Decl_7 = GenerDataInfoMp -> VarMp -> (Maybe Polarity) -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyVarIdS -> ( ([GenerDataInfo]),GenerDataInfoMp,VarMp,VarMp,T_Decl_8) type T_Decl_8 = ClGam -> ( ClGam,T_Decl_9) type T_Decl_9 = VarMp -> TyKiGam -> ClGam -> TyVarIdS -> ( ClGam,T_Decl_10) type T_Decl_10 = ClGam -> DataGam -> ( DataGam,DataGam,ValGam,VarMp,T_Decl_11) type T_Decl_11 = DataGam -> ( (Seq.FastSeq (CHRClassDecl)),(Seq.FastSeq (CHRScopedInstanceDecl)),ClassDefaultGam,T_Decl_12) type T_Decl_12 = VarMp -> ValGam -> VarMp -> ValGam -> VarMp -> ( VarMp,ValGam,T_Decl_13) type T_Decl_13 = CHRStore -> ClassDefaultGam -> TyVarIdS -> VarMp -> ValGam -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,TyKiGam,TyVarIdS,ScopeGam,VarMp,T_Decl_14) type T_Decl_14 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> Bool -> TyGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,([CExpr -> CExpr]),CSubst,ErrSq,CBindL,CBindL,(Seq.Seq (HsName,IdOccKind)),LamMp,ModEntRelFilterMp,VarMp,(Set.Set HsName),PP_Doc,PP_Doc,TrPP,CBindL,CBindL) -- Decls ------------------------------------------------------- -- semantic domain type T_Decls = ( Range,T_Decls_1) type T_Decls_1 = UID -> TyGam -> ( UID,TyGam,Bool,T_Decls_2) type T_Decls_2 = KiGam -> ( TyKiGam,T_Decls_3) type T_Decls_3 = Int -> Int -> ( Int,T_Decls_4) type T_Decls_4 = TyGam -> TyKiGam -> ( TyGam,T_Decls_5) type T_Decls_5 = TyKiGam -> TyGam -> VarMp -> ( TyKiGam,VarMp,T_Decls_6) type T_Decls_6 = VarMp -> PolGam -> TyKiGam -> ( VarMp,PolGam,T_Decls_7) type T_Decls_7 = GenerDataInfoMp -> VarMp -> (Maybe Polarity) -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyVarIdS -> ( ([GenerDataInfo]),GenerDataInfoMp,VarMp,VarMp,T_Decls_8) type T_Decls_8 = ClGam -> ( ClGam,T_Decls_9) type T_Decls_9 = VarMp -> TyKiGam -> ClGam -> TyVarIdS -> ( ClGam,T_Decls_10) type T_Decls_10 = ClGam -> DataGam -> ( DataGam,DataGam,ValGam,VarMp,T_Decls_11) type T_Decls_11 = DataGam -> ( (Seq.FastSeq (CHRClassDecl)),(Seq.FastSeq (CHRScopedInstanceDecl)),ClassDefaultGam,T_Decls_12) type T_Decls_12 = VarMp -> ValGam -> VarMp -> ValGam -> VarMp -> ( VarMp,ValGam,T_Decls_13) type T_Decls_13 = CHRStore -> ClassDefaultGam -> TyVarIdS -> VarMp -> ValGam -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,TyKiGam,TyVarIdS,ScopeGam,VarMp,T_Decls_14) type T_Decls_14 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> Bool -> TyGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,([CExpr -> CExpr]),CSubst,ErrSq,CBindL,CBindL,(Seq.Seq (HsName,IdOccKind)),LamMp,ModEntRelFilterMp,VarMp,(Set.Set HsName),PP_Doc,PP_Doc,TrPP,CBindL,CBindL) -- Expr -------------------------------------------------------- -- semantic domain type T_Expr = ( Range,T_Expr_1) type T_Expr_1 = UID -> ( UID,Bool,T_Expr_2) type T_Expr_2 = Bool -> KiGam -> Int -> Int -> ( Int,T_Expr_3) type T_Expr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,T_Expr_4) type T_Expr_4 = ClGam -> VarMp -> TyKiGam -> DataGam -> TyVarIdS -> ( DataGam,T_Expr_5) type T_Expr_5 = DataGam -> ( (Seq.FastSeq (CHRClassDecl)),FIIn,(Seq.FastSeq (CHRScopedInstanceDecl)),ClassDefaultGam,T_Expr_6) type T_Expr_6 = CHRStore -> ClassDefaultGam -> FIOpts -> Ty -> VarMp -> TyVarIdS -> VarMp -> ValGam -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,ValGam,TyVarIdS,Ty,VarMp,T_Expr_7) type T_Expr_7 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> ExprCtxt -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,([Coe]),([PP_Doc]),CExpr,HsName,PP_Doc,([(CBindCateg,CBindL)]),CSubst,UIDS,CExpr,ErrSq,([(CBindCateg,CBindL)]),(FieldUpdateL CExpr),ClGam,(Seq.Seq (HsName,IdOccKind)),KiGam,LamMp,ModEntRelFilterMp,PolGam,VarMp,TyGam,TyKiGam,Bool,([PP_Doc]),PP_Doc,CExpr,([(CBindCateg,CBindL)]),([(CBindCateg,CBindL)]),CBindL,(Set.Set HsName),PP_Doc,PP_Doc,TrPP) -- ExprAnn ----------------------------------------------------- -- semantic domain type T_ExprAnn = ( PP_Doc) -- FuncDep ----------------------------------------------------- -- semantic domain type T_FuncDep = UID -> ( UID,T_FuncDep_1) type T_FuncDep_1 = TyGam -> ( TyGam,T_FuncDep_2) type T_FuncDep_2 = TyKiGam -> ( TyKiGam,T_FuncDep_3) type T_FuncDep_3 = TyL -> VarMp -> TyKiGam -> VarMp -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,([ClsFuncDep]),ModEntRelFilterMp,PP_Doc,PP_Doc,Range,TrPP) -- FuncDeps ---------------------------------------------------- -- semantic domain type T_FuncDeps = UID -> ( UID,T_FuncDeps_1) type T_FuncDeps_1 = TyGam -> ( TyGam,T_FuncDeps_2) type T_FuncDeps_2 = TyKiGam -> ( TyKiGam,T_FuncDeps_3) type T_FuncDeps_3 = TyL -> VarMp -> TyKiGam -> VarMp -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,([ClsFuncDep]),ModEntRelFilterMp,PP_Doc,PP_Doc,([PP_Doc]),Range,TrPP) -- KiExpr ------------------------------------------------------ -- semantic domain type T_KiExpr = ( Range,T_KiExpr_1) type T_KiExpr_1 = UID -> ( UID,T_KiExpr_2) type T_KiExpr_2 = KiGam -> ( Ty,KiGam,T_KiExpr_3) type T_KiExpr_3 = VarMp -> TyKiGam -> VarMp -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,([PP_Doc]),HsName,PP_Doc,ErrSq,ModEntRelFilterMp,PP_Doc,PP_Doc,TrPP) -- KiExprAnn --------------------------------------------------- -- semantic domain type T_KiExprAnn = ( PP_Doc) -- MbTyExpr ---------------------------------------------------- -- semantic domain type T_MbTyExpr = ( Range,T_MbTyExpr_1) type T_MbTyExpr_1 = UID -> ( UID,T_MbTyExpr_2) type T_MbTyExpr_2 = Polarity -> PolGam -> VarMp -> TyGam -> ( VarMp,(Maybe Ty),T_MbTyExpr_3) type T_MbTyExpr_3 = VarMp -> TyKiGam -> ( TyKiGam,VarMp,T_MbTyExpr_4) type T_MbTyExpr_4 = ClGam -> VarMp -> TyKiGam -> VarMp -> KiGam -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,HsNameS,HsNameS,ErrSq,ModEntRelFilterMp,PP_Doc,PP_Doc,(Maybe PP_Doc),TrPP,TyGam,TyKiGam,TyVarWildMp) -- PatExpr ----------------------------------------------------- -- semantic domain type T_PatExpr = ( Range,T_PatExpr_1) type T_PatExpr_1 = UID -> ( UID,T_PatExpr_2) type T_PatExpr_2 = KiGam -> Int -> Int -> ( Int,T_PatExpr_3) type T_PatExpr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,TyGam,TyKiGam,T_PatExpr_4) type T_PatExpr_4 = ClGam -> DataGam -> VarMp -> TyKiGam -> TyVarIdS -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),HsName,T_PatExpr_5) type T_PatExpr_5 = ValGam -> ( Int,(Maybe HsName),Ty,T_PatExpr_6) type T_PatExpr_6 = FIOpts -> Bool -> Ty -> TyL -> VarMp -> ValGam -> ( VarMp,ValGam,T_PatExpr_7) type T_PatExpr_7 = CHRStore -> ClassDefaultGam -> VarMp -> TyVarIdS -> VarMp -> TyVarIdS -> ( RPatNm,ConstraintToInfoMap,RangeMp,ScopeGam,Ty,VarMp,T_PatExpr_8) type T_PatExpr_8 = CSubst -> HsName -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> VarMp -> ( ErrSq,([PP_Doc]),HsName,PP_Doc,CSubst,ErrSq,FieldSplitL,ModEntRelFilterMp,VarMp,Bool,CPatRest,PP_Doc,PP_Doc,RPat,TrPP,CBindL) -- PatExprAnn -------------------------------------------------- -- semantic domain type T_PatExprAnn = ( PP_Doc) -- PrExpr ------------------------------------------------------ -- semantic domain type T_PrExpr = ( Range,T_PrExpr_1) type T_PrExpr_1 = UID -> ( UID,T_PrExpr_2) type T_PrExpr_2 = TyGam -> ( Ty,Ty,TyGam,T_PrExpr_3) type T_PrExpr_3 = Polarity -> ( ([Polarity]),T_PrExpr_4) type T_PrExpr_4 = PolGam -> VarMp -> ( VarMp,T_PrExpr_5) type T_PrExpr_5 = TyKiGam -> ( TyKiGam,TyKiGam,T_PrExpr_6) type T_PrExpr_6 = VarMp -> ( PolGam,Ty,VarMp,TyVarWildMp,T_PrExpr_7) type T_PrExpr_7 = ClGam -> ( Ty,T_PrExpr_8) type T_PrExpr_8 = VarMp -> TyKiGam -> VarMp -> KiGam -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,HsNameS,HsNameS,ErrSq,ModEntRelFilterMp,PP_Doc,PP_Doc,Pred,TrPP) -- PrExprs ----------------------------------------------------- -- semantic domain type T_PrExprs = ClGam -> VarMp -> TyKiGam -> VarMp -> UID -> KiGam -> VarMp -> Polarity -> HsName -> EHCOpts -> PolGam -> VarMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyGam -> TyKiGam -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,HsNameS,HsNameS,ErrSq,UID,ModEntRelFilterMp,TyKiGam,VarMp,VarMp,PP_Doc,PP_Doc,([PP_Doc]),([Pred]),Range,TrPP,TyGam,TyKiGam,TyL,TyVarWildMp) -- RecExpr ----------------------------------------------------- -- semantic domain type T_RecExpr = ( Range,T_RecExpr_1) type T_RecExpr_1 = UID -> ( UID,T_RecExpr_2) type T_RecExpr_2 = KiGam -> Int -> Int -> ( Int,T_RecExpr_3) type T_RecExpr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,T_RecExpr_4) type T_RecExpr_4 = ClGam -> VarMp -> TyKiGam -> DataGam -> TyVarIdS -> ( DataGam,T_RecExpr_5) type T_RecExpr_5 = DataGam -> ([HsName]) -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),([HsName]),T_RecExpr_6) type T_RecExpr_6 = CHRStore -> ClassDefaultGam -> FIOpts -> Ty -> VarMp -> TyVarIdS -> VarMp -> ValGam -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,TyVarIdS,VarMp,T_RecExpr_7) type T_RecExpr_7 = CSubst -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> ( ErrSq,CSubst,ErrSq,HsName,(FieldUpdateL CExpr),ModEntRelFilterMp,VarMp,Bool,PP_Doc,PP_Doc,([PP_Doc]),CExpr,TrPP,Ty) -- RecPatExpr -------------------------------------------------- -- semantic domain type T_RecPatExpr = ( Range,T_RecPatExpr_1) type T_RecPatExpr_1 = UID -> ( UID,T_RecPatExpr_2) type T_RecPatExpr_2 = KiGam -> Int -> Int -> ( Int,T_RecPatExpr_3) type T_RecPatExpr_3 = GenerDataInfoMp -> VarMp -> EHCOpts -> PolGam -> VarMp -> PredScope -> TyGam -> TyKiGam -> TyVarIdS -> ( GenerDataInfoMp,VarMp,VarMp,TyGam,TyKiGam,T_RecPatExpr_4) type T_RecPatExpr_4 = ClGam -> DataGam -> VarMp -> TyKiGam -> ([HsName]) -> TyVarIdS -> ( (Seq.FastSeq (CHRScopedInstanceDecl)),Bool,([HsName]),T_RecPatExpr_5) type T_RecPatExpr_5 = FIOpts -> Ty -> Bool -> VarMp -> ValGam -> ValGam -> ( VarMp,ValGam,T_RecPatExpr_6) type T_RecPatExpr_6 = CHRStore -> ClassDefaultGam -> VarMp -> TyVarIdS -> VarMp -> TyVarIdS -> ( ConstraintToInfoMap,RangeMp,ScopeGam,Ty,VarMp,T_RecPatExpr_7) type T_RecPatExpr_7 = CSubst -> HsName -> EvidKeyToCBindMap -> PredScopeToCBindMap -> VarMp -> ValGam -> HsName -> RangeMp -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> VarMp -> ( ErrSq,CSubst,ErrSq,HsName,FieldSplitL,ModEntRelFilterMp,VarMp,CPatRest,PP_Doc,PP_Doc,([PP_Doc]),TrPP,CBindL) -- RowTyExpr --------------------------------------------------- -- semantic domain type T_RowTyExpr = ( Range,T_RowTyExpr_1) type T_RowTyExpr_1 = UID -> ([HsName]) -> ( UID,([HsName]),T_RowTyExpr_2) type T_RowTyExpr_2 = TyGam -> ( TyGam,Ty,T_RowTyExpr_3) type T_RowTyExpr_3 = Polarity -> PolGam -> VarMp -> ( VarMp,T_RowTyExpr_4) type T_RowTyExpr_4 = TyKiGam -> ( TyKiGam,TyKiGam,T_RowTyExpr_5) type T_RowTyExpr_5 = VarMp -> ( VarMp,TyVarWildMp,T_RowTyExpr_6) type T_RowTyExpr_6 = ClGam -> VarMp -> TyKiGam -> VarMp -> KiGam -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,HsNameS,HsNameS,ErrSq,HsName,ModEntRelFilterMp,PP_Doc,PP_Doc,([PP_Doc]),TrPP) -- TyExpr ------------------------------------------------------ -- semantic domain type T_TyExpr = ( Range,T_TyExpr_1) type T_TyExpr_1 = UID -> ( UID,T_TyExpr_2) type T_TyExpr_2 = TyGam -> ( Ty,TyGam,T_TyExpr_3) type T_TyExpr_3 = Polarity -> ( ([Polarity]),T_TyExpr_4) type T_TyExpr_4 = PolGam -> VarMp -> ( (Maybe Strictness),VarMp,T_TyExpr_5) type T_TyExpr_5 = TyKiGam -> ( TyKiGam,TyKiGam,T_TyExpr_6) type T_TyExpr_6 = VarMp -> ( PolGam,Ty,VarMp,Polarity,TyVarWildMp,T_TyExpr_7) type T_TyExpr_7 = ClGam -> ( Ty,T_TyExpr_8) type T_TyExpr_8 = VarMp -> TyKiGam -> VarMp -> KiGam -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,([PP_Doc]),HsName,PP_Doc,HsNameS,HsNameS,ErrSq,ModEntRelFilterMp,PP_Doc,PP_Doc,TrPP,TyL) -- TyExprAnn --------------------------------------------------- -- semantic domain type T_TyExprAnn = ( TyAnn,Bool,(Maybe Strictness),PP_Doc) -- TyExprs ----------------------------------------------------- -- semantic domain type T_TyExprs = ( Range,T_TyExprs_1) type T_TyExprs_1 = UID -> ( UID,T_TyExprs_2) type T_TyExprs_2 = TyGam -> ( ([Polarity]),TyGam,TyL,T_TyExprs_3) type T_TyExprs_3 = PolGam -> VarMp -> ( VarMp,T_TyExprs_4) type T_TyExprs_4 = TyKiGam -> ( TyKiGam,TyKiGam,T_TyExprs_5) type T_TyExprs_5 = VarMp -> ( PolGam,TyL,VarMp,TyVarWildMp,T_TyExprs_6) type T_TyExprs_6 = ClGam -> VarMp -> TyKiGam -> VarMp -> KiGam -> Polarity -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,HsNameS,HsNameS,ErrSq,ModEntRelFilterMp,PP_Doc,PP_Doc,([PP_Doc]),TrPP) -- TyVar ------------------------------------------------------- -- semantic domain type T_TyVar = ( Range,T_TyVar_1) type T_TyVar_1 = UID -> ( UID,T_TyVar_2) type T_TyVar_2 = TyGam -> ( TyGam,T_TyVar_3) type T_TyVar_3 = TyKiGam -> ( PolGam,TyKiGam,Ty,([Polarity]),Ty,TyKiGam,T_TyVar_4) type T_TyVar_4 = VarMp -> TyKiGam -> VarMp -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,ModEntRelFilterMp,HsName,PP_Doc,PP_Doc,TrPP) -- TyVars ------------------------------------------------------ -- semantic domain type T_TyVars = ( Range,T_TyVars_1) type T_TyVars_1 = UID -> ( UID,T_TyVars_2) type T_TyVars_2 = TyGam -> ( TyGam,T_TyVars_3) type T_TyVars_3 = TyKiGam -> ( PolGam,TyKiGam,TyL,([Polarity]),TyKiGam,TyL,T_TyVars_4) type T_TyVars_4 = VarMp -> TyKiGam -> VarMp -> HsName -> EHCOpts -> ToSysfEnv -> (TraceOn -> [PP_Doc] -> TrPP) -> TyVarIdS -> TyVarIdS -> TyVarIdS -> TyVarIdS -> ( ErrSq,ErrSq,ModEntRelFilterMp,([HsName]),PP_Doc,PP_Doc,([PP_Doc]),TrPP)