FitsInCommon.hs

module UHC.Light.Compiler.Ty.FitsInCommon
( FIOut (..), emptyFO, foHasErrs
, foErrSq
, FitsIn, FitsIn'
, trfit, trfitIn, trfitOu
, foAppSpineInfo
, foPlusVarMp, foSetVarMp, foBindTyVar
, AppSpineVertebraeInfo (..)
, unknownAppSpineVertebraeInfo
, unknownAppSpineVertebraeInfoL
, AppSpineInfo (asgiVertebraeL), emptyAppSpineInfo, asgiShift1SpinePos, asgiSpine
, fitsInLWith
, AppSpineFOUpdCoe
, asUpdateByPolarity )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Error
import qualified UHC.Util.FastSeq as Seq
import UHC.Light.Compiler.VarMp
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Substitutable
import UHC.Util.Pretty
import qualified Data.Set as Set
import UHC.Light.Compiler.AbstractCore
import UHC.Light.Compiler.CHR.Constraint
import UHC.Light.Compiler.Core
import UHC.Light.Compiler.Core.Coercion
import UHC.Light.Compiler.Core.Subst








{-# LINE 46 "src/ehc/Ty/FitsInCommon.chs" #-}
trfit :: String -> String -> PP_Doc -> PP_Doc
trfit dir msg rest =  dir >|< "." >|< msg >|< ":" >#< rest

trfitIn = trfit ">"
trfitOu = trfit "<"

{-# LINE 64 "src/ehc/Ty/FitsInCommon.chs" #-}
foErrSq :: FIOut -> ErrSq
foErrSq = Seq.fromList . foErrL

{-# LINE 77 "src/ehc/Ty/FitsInCommon.chs" #-}
data FIOut
  =  FIOut
       {  foVarMp           :: !VarMp					-- tvar bindings found during fitsIn
       ,  foTy              :: !Ty						-- the unified type
       ,  foUniq            :: !UID						-- uniq value seed for fresh tvars
       ,  foMbAppSpineInfo  :: !(Maybe AppSpineInfo)	-- Ty_App spine info
       ,  foErrL            :: !ErrL					-- errors
       ,  foTrace           :: [PP_Doc]					-- trace
       ,  foLInstToL        :: [InstTo]					-- instantiation over arrow '->' of left ty
       ,  foRInstToL        :: [InstTo]					-- instantiation over arrow '->' of right ty
       ,  foDontBind        :: !TyVarIdS				-- output variant of fioDontBind
       ,  foCSubst          :: !CSubst					-- subst for holes in the Core
       ,  foLRCoe           :: !LRCoe					-- coercion over arrow structure
       ,  foPredOccL        :: ![PredOcc]				-- arisen predicates (to be obsolete)
       ,  foGathCnstrMp     :: !ConstraintToInfoMap		-- arisen predicates
       ,  foRowCoeL         :: !(AssocL HsName Coe)		-- internal, coercions for row fields
       }

{-# LINE 115 "src/ehc/Ty/FitsInCommon.chs" #-}
emptyFO
  =  FIOut
       {  foVarMp           =   emptyVarMp
       ,  foTy              =   Ty_Any
       ,  foUniq            =   uidStart
       ,  foMbAppSpineInfo  =   Nothing
       ,  foErrL            =   []
       ,  foTrace           =   []
       ,  foLInstToL        =   []
       ,  foRInstToL        =   []
       ,  foDontBind        =	Set.empty
       ,  foCSubst          =   emptyCSubst
       ,  foLRCoe           =   emptyLRCoe
       ,  foPredOccL        =   []
       ,  foGathCnstrMp     =   emptyCnstrMp
       ,  foRowCoeL         =   []
       }

{-# LINE 150 "src/ehc/Ty/FitsInCommon.chs" #-}
foHasErrs :: FIOut -> Bool
foHasErrs = not . null . foErrL

{-# LINE 155 "src/ehc/Ty/FitsInCommon.chs" #-}
foAppSpineInfo :: FIOut -> AppSpineInfo
foAppSpineInfo fo = maybe emptyAppSpineInfo id $ foMbAppSpineInfo fo

{-# LINE 164 "src/ehc/Ty/FitsInCommon.chs" #-}
foPlusVarMp :: VarMp -> FIOut -> FIOut
foPlusVarMp c fo = fo {foVarMp = c |+> foVarMp fo}

foSetVarMp :: VarMp -> FIOut -> FIOut
foSetVarMp  c fo = fo {foVarMp = c}

foBindTyVar :: TyVarId -> Ty -> FIOut -> FIOut
foBindTyVar v t = foPlusVarMp (v `varmpTyUnit` t)

{-# LINE 179 "src/ehc/Ty/FitsInCommon.chs" #-}
type AppSpineFOUpdCoe = EHCOpts -> [FIOut] -> FIOut

{-# LINE 183 "src/ehc/Ty/FitsInCommon.chs" #-}
data AppSpineVertebraeInfo
  =  AppSpineVertebraeInfo
       { asPolarity     :: Polarity						-- the polarity on this spine position
       , asFIO          :: FIOpts -> FIOpts				-- how to update the context (swap ...)
       , asFO			:: FIOut -> FIOut -> FIOut		-- \ffo afo -> afo, update app function arg FIOut with app function FIOut
       , asMbFOUpdCoe   :: Maybe AppSpineFOUpdCoe		-- possibly update coercion
       }

{-# LINE 195 "src/ehc/Ty/FitsInCommon.chs" #-}
instance Show AppSpineVertebraeInfo where
  show _ = "AppSpineVertebraeInfo"

instance PP AppSpineVertebraeInfo where
  pp = pp . asPolarity

{-# LINE 203 "src/ehc/Ty/FitsInCommon.chs" #-}
unknownAppSpineVertebraeInfo :: AppSpineVertebraeInfo
unknownAppSpineVertebraeInfo
  = AppSpineVertebraeInfo
      polInvariant fioMkUnify
      asFODflt
      Nothing

{-# LINE 214 "src/ehc/Ty/FitsInCommon.chs" #-}
asFODflt :: FIOut -> FIOut -> FIOut
asFODflt _ afo = afo

{-# LINE 219 "src/ehc/Ty/FitsInCommon.chs" #-}
unknownAppSpineVertebraeInfoL :: [AppSpineVertebraeInfo]
unknownAppSpineVertebraeInfoL = repeat unknownAppSpineVertebraeInfo

{-# LINE 224 "src/ehc/Ty/FitsInCommon.chs" #-}
asUpdateByPolarity :: Polarity -> AppSpineVertebraeInfo -> AppSpineVertebraeInfo
asUpdateByPolarity pol as
  = as {asPolarity = pol, asFIO = mkfio}
  where mkfio | polIsContravariant pol = fioMkStrong
              | polIsCovariant     pol = id
              | otherwise              = fioMkUnify

{-# LINE 233 "src/ehc/Ty/FitsInCommon.chs" #-}
data AppSpineInfo
  = AppSpineInfo
      { asgiSpinePos   :: Int
      , asgiVertebraeL :: [AppSpineVertebraeInfo]
      }

instance Show AppSpineInfo where
  show _ = "AppSpineInfo"

instance PP AppSpineInfo where
  pp i = ppBracketsCommas (take 5 $ asgiVertebraeL i) >|< "@" >|< asgiSpinePos i

emptyAppSpineInfo :: AppSpineInfo
emptyAppSpineInfo = AppSpineInfo 0 unknownAppSpineVertebraeInfoL

asgiShift1SpinePos :: AppSpineInfo -> AppSpineInfo
asgiShift1SpinePos i = i {asgiSpinePos = asgiSpinePos i + 1}

asgiSpine :: AppSpineInfo -> [AppSpineVertebraeInfo]
asgiSpine i = drop (asgiSpinePos i) $ asgiVertebraeL i

{-# LINE 260 "src/ehc/Ty/FitsInCommon.chs" #-}
type FitsIn' = FIOpts -> UID -> VarMp -> Ty -> Ty -> FIOut
type FitsIn = FIOpts -> UID -> VarMp -> Ty -> Ty -> (Ty,VarMp,ErrL)

{-# LINE 265 "src/ehc/Ty/FitsInCommon.chs" #-}
fitsInLWith :: (FIOut -> FIOut -> FIOut) -> FitsIn' -> FIOpts -> UID -> VarMp -> TyL -> TyL -> ([FIOut],FIOut)
fitsInLWith foCmb elemFits opts uniq varmp tyl1 tyl2
  = (foL,fo)
  where ((_,fo),foL)
          = foldr  (\(t1,t2) ((u,foThr),foL)
                      -> let  (u',ue) = mkNewLevUID u
                              fo = elemFits opts ue (foVarMp foThr `varUpd` varmp) (foVarMp foThr `varUpd` t1) (foVarMp foThr `varUpd` t2)
                         in   ((u',foCmb fo foThr),fo:foL)
                   )
                   ((uniq,emptyFO),[])
            . zip tyl1
            $ tyl2