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 VarLookupKey VarMp = VarId
type instance VarLookupVal VarMp = VarMpInfo

{-
type instance VarLookupKey (VarMp' k v) = k
type instance VarLookupVal (VarMp' k v) = v
-}

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

type instance ExtrValVarKey Ty = TyVarId

instance VarExtractable Ty where
  varFreeSet    = tyFtv

{-# LINE 108 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable Label VarMp where
instance (VarLookup m, VarLookupKey m ~ ImplsVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable Label m where
  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, VarLookupKey m ~ UID, VarLookupVal m ~ VarMpInfo) => VarUpdatable LabelOffset m where
  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 131 "src/ehc/Substitutable.chs" #-}
{- 20160421: in uhc-util
-- instance (VarUpdatable vv subst) => VarUpdatable [vv] subst where
instance (Ord (VarLookupKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where
  s      `varUpd`  l   =   map (varUpd s) l
  s      `varUpdCyc` l   =   (l,varmpUnions m)
                  where (l,m) = unzip $ map (varUpdCyc s) l
-}

{- 20160411: in uhc-util
instance (VarExtractable vv) => VarExtractable [vv] where
  varFreeSet      l   =   Set.unions $ map varFreeSet l
-}

{-# LINE 173 "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
  varUpd                                =   (|+>)

type instance ExtrValVarKey VarMp = TyVarId

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

{-# LINE 184 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
  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 193 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable Pred VarMp where
  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, VarLookupKey m ~ ImplsVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable PredScope m where
  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
  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
  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
  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
  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 261 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable VarMpInfo VarMp where
  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 279 "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 315 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable PredSeq VarMp where
  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 333 "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 363 "src/ehc/Substitutable.chs" #-}
setSubst :: VarMp -> TyVarIdS -> TyVarIdS
setSubst m s = varFreeSet $ (varUpd m) $ map mkTyVar $ Set.toList s

{-# LINE 372 "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 392 "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 409 "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 ]