module UHC.Light.Compiler.Substitutable
( module UHC.Util.Substitutable
, ppS
, substLift
, varmpMapTyVarKey
, setSubst
, tyFixTyVars, tyMetaTyVars
, varmpinfoFtvMp
, varmpOccurErr )
where
import Data.List
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.VarMp
import UHC.Util.Substitutable
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Ty.Trf.Subst
import UHC.Light.Compiler.Ty.Ftv
import qualified Data.Set as Set
import UHC.Util.Pretty
import UHC.Light.Compiler.Error
import qualified Data.Map as Map
import UHC.Light.Compiler.VarLookup
import UHC.Light.Compiler.Base.TermLike







{-# LINE 49 "src/ehc/Substitutable.chs" #-}
substLift :: (v' -> v) -> (v' -> v -> v') -> (subst -> v -> (v,r)) -> subst -> v' -> (v',r)
substLift toV updV app s v'
  = (updV v' x,r)
  where (x,r) = app s $ toV v'

{-# LINE 60 "src/ehc/Substitutable.chs" #-}
varmpinfoFtvMp :: VarMpInfo -> TvCatMp
varmpinfoFtvMp i
  = case i of
      VMITy       t  -> tyFtvMp    t
      VMIImpls    i  -> implsFtvMp i
      _              -> emptyTvCatMp		-- incomplete

{-# LINE 73 "src/ehc/Substitutable.chs" #-}
type instance SubstVarKey VarMp = VarId
type instance SubstVarVal VarMp = VarMpInfo

type instance SubstVarKey (VarMp' k v) = k
type instance SubstVarVal (VarMp' k v) = v

{-# LINE 89 "src/ehc/Substitutable.chs" #-}
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ TyVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable Ty m where
  -- type SubstVarKey m = SubstVarKey m
  -- type SubstVarVal m = SubstVarVal m
  varUpd     	= tyAppVarLookup
  varUpdCyc    = tyAppVarLookup2

type instance ExtrValVarKey Ty = TyVarId

instance VarExtractable Ty where
  varFreeSet    = tyFtv

{-# LINE 110 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable Label VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ ImplsVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable Label m where
  -- type SubstVarKey m = ImplsVarId
  -- type SubstVarVal m = VarMpInfo
  s `varUpd` lb          = maybe lb id $ varmpLabelLookupLabelCyc lb s

type instance ExtrValVarKey Label = TyVarId

instance VarExtractable Label where
  varFree (Label_Var v) = [v]
  varFree _             = []

-- instance VarUpdatable LabelOffset VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ UID, SubstVarVal m ~ VarMpInfo) => VarUpdatable LabelOffset m where
  -- type SubstVarKey m = UID
  -- type SubstVarVal m = VarMpInfo
  s `varUpd` o@(LabelOffset_Var v) = maybe o id $ varmpOffsetLookup v s
  s `varUpd` o                     = o

type instance ExtrValVarKey LabelOffset = TyVarId

instance VarExtractable LabelOffset where
  varFree (LabelOffset_Var v) = [v]
  varFree _                   = []

{-# LINE 137 "src/ehc/Substitutable.chs" #-}
-- instance (VarUpdatable vv subst) => VarUpdatable [vv] subst where
instance (Ord (SubstVarKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where
  -- type SubstVarKey subst = SubstVarKey subst
  -- type SubstVarVal subst = SubstVarVal subst
  s      `varUpd`  l   =   map (varUpd s) l
  s      `varUpdCyc` l   =   (l,varmpUnions m)
                  where (l,m) = unzip $ map (varUpdCyc s) l

instance (VarExtractable vv) => VarExtractable [vv] where
  varFreeSet      l   =   Set.unions $ map varFreeSet l

{-# LINE 181 "src/ehc/Substitutable.chs" #-}
-- instance VarLookupCmb m (VarMp' k v) => VarUpdatable (VarMp' k v) m where
instance VarLookupCmb (VarMp' k v) (VarMp' k v) => VarUpdatable (VarMp' k v) (VarMp' k v) where
  -- type SubstVarKey (VarMp' k v) = k
  -- type SubstVarVal (VarMp' k v) = v
  varUpd                                =   (|+>)

type instance ExtrValVarKey VarMp = TyVarId

instance VarExtractable VarMp where
  varFreeSet               (VarMp _ sl)    =   Set.unions $ map (varFreeSet . Map.elems) sl

{-# LINE 194 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
  -- type SubstVarKey subst = SubstVarKey subst
  -- type SubstVarVal subst = SubstVarVal subst
  s `varUpd`  (k,v) =  (k,s `varUpd` v)

instance (VarExtractable vv, ExtrValVarKey vv ~ ExtrValVarKey (HsName,vv)) => VarExtractable (HsName,vv) where
  varFreeSet (_,v) =  varFreeSet v

{-# LINE 205 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable Pred VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  p  =  (\(Ty_Pred p) -> p) (s `varUpd` (Ty_Pred p))

type instance ExtrValVarKey Pred = TyVarId

instance VarExtractable Pred where
  varFreeSet p  =  varFreeSet (Ty_Pred p)

-- instance VarUpdatable PredScope VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ ImplsVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable PredScope m where
  -- type SubstVarKey m = ImplsVarId
  -- type SubstVarVal m = VarMpInfo
  s `varUpd`  sc                   = maybe sc id $ varmpScopeLookupScopeCyc sc s

type instance ExtrValVarKey PredScope = TyVarId

instance VarExtractable PredScope where
  varFree    (PredScope_Var v)    = [v]
  varFree    _                    = []

instance VarUpdatable CHRPredOccCxt VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  (CHRPredOccCxt_Scope1 sc) = CHRPredOccCxt_Scope1 (s `varUpd` sc)

type instance ExtrValVarKey CHRPredOccCxt = TyVarId

instance VarExtractable CHRPredOccCxt where
  varFree    (CHRPredOccCxt_Scope1 sc) = varFree sc

instance VarUpdatable PredOcc VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  (PredOcc pr id sc r)  = PredOcc (s `varUpd` pr) id (s `varUpd` sc) r

type instance ExtrValVarKey PredOcc = TyVarId

instance VarExtractable PredOcc where
  varFreeSet (PredOcc pr id sc _)  = varFreeSet pr `Set.union` varFreeSet sc

instance VarUpdatable CHRPredOcc VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  (CHRPredOcc pr sc r)  = CHRPredOcc (s `varUpd` pr) (s `varUpd` sc) r

type instance ExtrValVarKey CHRPredOcc = TyVarId

instance VarExtractable CHRPredOcc where
  varFreeSet (CHRPredOcc pr sc _)  = varFreeSet pr `Set.union` varFreeSet sc

instance VarUpdatable Impls VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  i  =  (\(Ty_Impls i) -> i) (s `varUpd` (Ty_Impls i))

type instance ExtrValVarKey Impls = TyVarId

instance VarExtractable Impls where
  varFreeSet i  =  varFreeSet (Ty_Impls i)

{-# LINE 285 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable VarMpInfo VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd` vmi =  case vmi of
                 VMITy       t  -> VMITy (s `varUpd` t)
                 VMIImpls    i  -> VMIImpls (s `varUpd` i)
                 VMIPred     i  -> VMIPred (s `varUpd` i)
                 VMIScope    sc -> VMIScope (s `varUpd` sc)
                 VMIPredSeq  x  -> VMIPredSeq (s `varUpd` x)
                 -- VMIExts     x  -> VMIExts (s `varUpd` x)
                 vmi            -> vmi

{-# LINE 305 "src/ehc/Substitutable.chs" #-}
type instance ExtrValVarKey VarMpInfo = VarId

instance VarExtractable VarMpInfo where
  varFreeSet vmi = case vmi of
                 VMITy       t  -> varFreeSet t
                 VMIImpls    i  -> varFreeSet i
                 VMIPred     i  -> varFreeSet i
                 VMIScope    sc -> varFreeSet sc
                 VMIPredSeq  x  -> varFreeSet x
                 -- VMIExts     x  -> varFreeSet x
                 vmi            -> Set.empty


{-# LINE 341 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable PredSeq VarMp where
  -- type SubstVarKey VarMp = VarId
  -- type SubstVarVal VarMp = VarMpInfo
  s `varUpd`  a@(PredSeq_Var  v  ) = maybe a id $ varmpPredSeqLookup v s
  s `varUpd`    (PredSeq_Cons h t) = PredSeq_Cons (s `varUpd` h) (s `varUpd` t)
  _ `varUpd`    x                  = x

type instance ExtrValVarKey PredSeq = TyVarId

instance VarExtractable PredSeq where
  varFreeSet   (PredSeq_Var  v  ) = Set.singleton v
  varFreeSet   (PredSeq_Cons h t) = varFreeSet h `Set.union` varFreeSet t
  varFreeSet _                    = Set.empty

{-# LINE 361 "src/ehc/Substitutable.chs" #-}
-- | Construct varmp for fixing tvars to new fresh fixed tvars + varmp for unfixing those to (again) fresh tvars, resp meta tvars
fixTyVarsVarMp :: UID -> Ty -> (VarMp,VarMp,VarMp,VarMp)
fixTyVarsVarMp uniq t
  = ( mk TyVarCateg_Fixed fv rv
    , mk TyVarCateg_Meta  fv rv
    , mk TyVarCateg_Plain rv rv2
    , mk TyVarCateg_Meta  rv rv2
    )
  where fv = varFree t
        l  = length fv
        (rv,rv2) = splitAt l $ mkNewUIDL (2*l) uniq
        mk cat fv rv = mkVarMp $ Map.fromList $ zipWith (\v r -> (v,VMITy (Ty_Var r cat))) fv rv

tyFixTyVars :: UID -> Ty -> (Ty,VarMp,VarMp,VarMp)
tyFixTyVars uniq t
  = (sTo `varUpd` t, sTo, sFr, smFr)
  where (sTo,_,sFr,smFr) = fixTyVarsVarMp uniq t

-- | replace tvars with tvars having TyVarCateg_Meta
tyMetaTyVars :: UID -> Ty -> Ty
tyMetaTyVars uniq t
  = smTo `varUpd` t
  where (_,smTo,_,_) = fixTyVarsVarMp uniq t

{-# LINE 391 "src/ehc/Substitutable.chs" #-}
setSubst :: VarMp -> TyVarIdS -> TyVarIdS
setSubst m s = varFreeSet $ (varUpd m) $ map mkTyVar $ Set.toList s

{-# LINE 400 "src/ehc/Substitutable.chs" #-}
varmpMapTyVarKey :: VarMp -> VarMp -> VarMp
varmpMapTyVarKey mMap m
  = varmpUnions [ varmpTyUnit v x | (Ty_Var v _,x) <- assocLMapKey (\v -> fst $ appUnAnnCanon $ mMap `varUpd` mkTyVar v) $ varmpToAssocTyL m ]


{-# LINE 420 "src/ehc/Substitutable.chs" #-}
ppS :: VarUpdatable x m => (x -> PP_Doc) -> m -> x -> PP_Doc
ppS pp c x = (pp $ c `varUpd` x) >#< ppParens (pp x)

{-# LINE 437 "src/ehc/Substitutable.chs" #-}
varmpOccurErr :: Range -> VarMp -> VarMp -> [Err]
varmpOccurErr r m mc = [ Err_OccurCycle r v (varmpDel [v] m `varUpd` t) | (v,t) <- varmpToAssocTyL mc ]