{-# 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 Data.Set (Set)
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)

instance Binary 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)