{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModuleShape (
    -- * Module shapes
    ModuleShape(..),
    emptyModuleShape,
    shapeInstalledPackage,
) where

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

import Distribution.ModuleName
import Distribution.InstalledPackageInfo as IPI

import Distribution.Backpack.ModSubst
import Distribution.Backpack

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

-----------------------------------------------------------------------
-- Module shapes

-- | A 'ModuleShape' describes the provisions and requirements of
-- a library.  We can extract a 'ModuleShape' from an
-- 'InstalledPackageInfo'.
data ModuleShape = ModuleShape {
    ModuleShape -> OpenModuleSubst
modShapeProvides :: OpenModuleSubst,
    ModuleShape -> Set ModuleName
modShapeRequires :: Set ModuleName
    }
    deriving (ModuleShape -> ModuleShape -> Bool
(ModuleShape -> ModuleShape -> Bool)
-> (ModuleShape -> ModuleShape -> Bool) -> Eq ModuleShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleShape -> ModuleShape -> Bool
$c/= :: ModuleShape -> ModuleShape -> Bool
== :: ModuleShape -> ModuleShape -> Bool
$c== :: ModuleShape -> ModuleShape -> Bool
Eq, Int -> ModuleShape -> ShowS
[ModuleShape] -> ShowS
ModuleShape -> String
(Int -> ModuleShape -> ShowS)
-> (ModuleShape -> String)
-> ([ModuleShape] -> ShowS)
-> Show ModuleShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleShape] -> ShowS
$cshowList :: [ModuleShape] -> ShowS
show :: ModuleShape -> String
$cshow :: ModuleShape -> String
showsPrec :: Int -> ModuleShape -> ShowS
$cshowsPrec :: Int -> ModuleShape -> ShowS
Show, (forall x. ModuleShape -> Rep ModuleShape x)
-> (forall x. Rep ModuleShape x -> ModuleShape)
-> Generic ModuleShape
forall x. Rep ModuleShape x -> ModuleShape
forall x. ModuleShape -> Rep ModuleShape x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ModuleShape x -> ModuleShape
$cfrom :: forall x. ModuleShape -> Rep ModuleShape x
Generic, Typeable)

instance Binary ModuleShape
instance Structured ModuleShape

instance ModSubst ModuleShape where
    modSubst :: OpenModuleSubst -> ModuleShape -> ModuleShape
modSubst OpenModuleSubst
subst (ModuleShape OpenModuleSubst
provs Set ModuleName
reqs)
        = OpenModuleSubst -> Set ModuleName -> ModuleShape
ModuleShape (OpenModuleSubst -> OpenModuleSubst -> OpenModuleSubst
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst OpenModuleSubst
provs) (OpenModuleSubst -> Set ModuleName -> Set ModuleName
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
subst Set ModuleName
reqs)

-- | The default module shape, with no provisions and no requirements.
emptyModuleShape :: ModuleShape
emptyModuleShape :: ModuleShape
emptyModuleShape = OpenModuleSubst -> Set ModuleName -> ModuleShape
ModuleShape OpenModuleSubst
forall k a. Map k a
Map.empty Set ModuleName
forall a. Set a
Set.empty

-- Food for thought: suppose we apply the Merkel tree optimization.
-- Imagine this situation:
--
--      component p
--          signature H
--          module P
--      component h
--          module H
--      component a
--          signature P
--          module A
--      component q(P)
--          include p
--          include h
--      component r
--          include q (P)
--          include p (P) requires (H)
--          include h (H)
--          include a (A) requires (P)
--
-- Component r should not have any conflicts, since after mix-in linking
-- the two P imports will end up being the same, so we can properly
-- instantiate it.  But to know that q's P is p:P instantiated with h:H,
-- we have to be able to expand its unit id.  Maybe we can expand it
-- lazily but in some cases it will need to be expanded.
--
-- FWIW, the way that GHC handles this is by improving unit IDs as
-- soon as it sees an improved one in the package database.  This
-- is a bit disgusting.
shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape
shapeInstalledPackage :: InstalledPackageInfo -> ModuleShape
shapeInstalledPackage InstalledPackageInfo
ipi = OpenModuleSubst -> Set ModuleName -> ModuleShape
ModuleShape ([(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ModuleName, OpenModule)]
provs) Set ModuleName
reqs
  where
    uid :: OpenUnitId
uid = InstalledPackageInfo -> OpenUnitId
installedOpenUnitId InstalledPackageInfo
ipi
    provs :: [(ModuleName, OpenModule)]
provs = (ExposedModule -> (ModuleName, OpenModule))
-> [ExposedModule] -> [(ModuleName, OpenModule)]
forall a b. (a -> b) -> [a] -> [b]
map ExposedModule -> (ModuleName, OpenModule)
shapeExposedModule (InstalledPackageInfo -> [ExposedModule]
IPI.exposedModules InstalledPackageInfo
ipi)
    reqs :: Set ModuleName
reqs = InstalledPackageInfo -> Set ModuleName
requiredSignatures InstalledPackageInfo
ipi
    shapeExposedModule :: ExposedModule -> (ModuleName, OpenModule)
shapeExposedModule (IPI.ExposedModule ModuleName
mod_name Maybe OpenModule
Nothing)
        = (ModuleName
mod_name, OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
uid ModuleName
mod_name)
    shapeExposedModule (IPI.ExposedModule ModuleName
mod_name (Just OpenModule
mod))
        = (ModuleName
mod_name, OpenModule
mod)