{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}

-- | A type class 'ModSubst' for objects which can have 'ModuleSubst'
-- applied to them.
--
-- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModSubst
  ( ModSubst (..)
  ) where

import Distribution.Compat.Prelude hiding (mod)
import Prelude ()

import Distribution.Backpack
import Distribution.ModuleName

import qualified Data.Map as Map
import qualified Data.Set as Set

-- | Applying module substitutions to semantic objects.
class ModSubst a where
  -- In notation, substitution is postfix, which implies
  -- putting it on the right hand side, but for partial
  -- application it's more convenient to have it on the left
  -- hand side.
  modSubst :: OpenModuleSubst -> a -> a

instance ModSubst OpenModule where
  modSubst :: OpenModuleSubst -> OpenModule -> OpenModule
modSubst OpenModuleSubst
subst (OpenModule OpenUnitId
cid ModuleName
mod_name) = OpenUnitId -> ModuleName -> OpenModule
OpenModule (OpenModuleSubst -> OpenUnitId -> OpenUnitId
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst OpenUnitId
cid) ModuleName
mod_name
  modSubst OpenModuleSubst
subst mod :: OpenModule
mod@(OpenModuleVar ModuleName
mod_name)
    | Just OpenModule
mod' <- ModuleName -> OpenModuleSubst -> Maybe OpenModule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name OpenModuleSubst
subst = OpenModule
mod'
    | Bool
otherwise = OpenModule
mod

instance ModSubst OpenUnitId where
  modSubst :: OpenModuleSubst -> OpenUnitId -> OpenUnitId
modSubst OpenModuleSubst
subst (IndefFullUnitId ComponentId
cid OpenModuleSubst
insts) = ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid (OpenModuleSubst -> OpenModuleSubst -> OpenModuleSubst
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst OpenModuleSubst
insts)
  modSubst OpenModuleSubst
_subst OpenUnitId
uid = OpenUnitId
uid

instance ModSubst (Set ModuleName) where
  modSubst :: OpenModuleSubst -> Set ModuleName -> Set ModuleName
modSubst OpenModuleSubst
subst Set ModuleName
reqs =
    Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
Set.union
      (Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set ModuleName
reqs (OpenModuleSubst -> Set ModuleName
forall k a. Map k a -> Set k
Map.keysSet OpenModuleSubst
subst))
      (OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles OpenModuleSubst
subst)

-- Substitutions are functorial.  NB: this means that
-- there is an @instance 'ModSubst' 'ModuleSubst'@!
instance ModSubst a => ModSubst (Map k a) where
  modSubst :: OpenModuleSubst -> Map k a -> Map k a
modSubst OpenModuleSubst
subst = (a -> a) -> Map k a -> Map k a
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OpenModuleSubst -> a -> a
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst)
instance ModSubst a => ModSubst [a] where
  modSubst :: OpenModuleSubst -> [a] -> [a]
modSubst OpenModuleSubst
subst = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OpenModuleSubst -> a -> a
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst)
instance ModSubst a => ModSubst (k, a) where
  modSubst :: OpenModuleSubst -> (k, a) -> (k, a)
modSubst OpenModuleSubst
subst (k
x, a
y) = (k
x, OpenModuleSubst -> a -> a
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst a
y)