{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}

-- | This module defines the core data types for Backpack.  For more
-- details, see:
--
--  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack
  ( -- * OpenUnitId
    OpenUnitId (..)
  , openUnitIdFreeHoles
  , mkOpenUnitId

    -- * DefUnitId
  , DefUnitId
  , unDefUnitId
  , mkDefUnitId

    -- * OpenModule
  , OpenModule (..)
  , openModuleFreeHoles

    -- * OpenModuleSubst
  , OpenModuleSubst
  , dispOpenModuleSubst
  , dispOpenModuleSubstEntry
  , parsecOpenModuleSubst
  , parsecOpenModuleSubstEntry
  , openModuleSubstFreeHoles

    -- * Conversions to 'UnitId'
  , abstractUnitId
  , hashModuleSubst
  ) where

import Distribution.Compat.Prelude hiding (mod)
import Distribution.Parsec
import Distribution.Pretty
import Text.PrettyPrint (hcat)
import Prelude ()

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

import Distribution.ModuleName
import Distribution.Types.ComponentId
import Distribution.Types.Module
import Distribution.Types.UnitId
import Distribution.Utils.Base62

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

-----------------------------------------------------------------------
-- OpenUnitId

-- | An 'OpenUnitId' describes a (possibly partially) instantiated
-- Backpack component, with a description of how the holes are filled
-- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured
-- form that allows for substitution (which fills in holes.) This form
-- of unit cannot be installed. It must first be converted to a
-- 'UnitId'.
--
-- In the absence of Backpack, there are no holes to fill, so any such
-- component always has an empty module substitution; thus we can lossily
-- represent it as a 'DefiniteUnitId uid'.
--
-- For a source component using Backpack, however, there is more
-- structure as components may be parametrized over some signatures, and
-- these \"holes\" may be partially or wholly filled.
--
-- OpenUnitId plays an important role when we are mix-in linking,
-- and is recorded to the installed packaged database for indefinite
-- packages; however, for compiled packages that are fully instantiated,
-- we instantiate 'OpenUnitId' into 'UnitId'.
--
-- For more details see the Backpack spec
-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
data OpenUnitId
  = -- | Identifies a component which may have some unfilled holes;
    -- specifying its 'ComponentId' and its 'OpenModuleSubst'.
    -- TODO: Invariant that 'OpenModuleSubst' is non-empty?
    -- See also the Text instance.
    IndefFullUnitId ComponentId OpenModuleSubst
  | -- | Identifies a fully instantiated component, which has
    -- been compiled and abbreviated as a hash.  The embedded 'UnitId'
    -- MUST NOT be for an indefinite component; an 'OpenUnitId'
    -- is guaranteed not to have any holes.
    DefiniteUnitId DefUnitId
  deriving ((forall x. OpenUnitId -> Rep OpenUnitId x)
-> (forall x. Rep OpenUnitId x -> OpenUnitId) -> Generic OpenUnitId
forall x. Rep OpenUnitId x -> OpenUnitId
forall x. OpenUnitId -> Rep OpenUnitId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OpenUnitId -> Rep OpenUnitId x
from :: forall x. OpenUnitId -> Rep OpenUnitId x
$cto :: forall x. Rep OpenUnitId x -> OpenUnitId
to :: forall x. Rep OpenUnitId x -> OpenUnitId
Generic, ReadPrec [OpenUnitId]
ReadPrec OpenUnitId
Int -> ReadS OpenUnitId
ReadS [OpenUnitId]
(Int -> ReadS OpenUnitId)
-> ReadS [OpenUnitId]
-> ReadPrec OpenUnitId
-> ReadPrec [OpenUnitId]
-> Read OpenUnitId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS OpenUnitId
readsPrec :: Int -> ReadS OpenUnitId
$creadList :: ReadS [OpenUnitId]
readList :: ReadS [OpenUnitId]
$creadPrec :: ReadPrec OpenUnitId
readPrec :: ReadPrec OpenUnitId
$creadListPrec :: ReadPrec [OpenUnitId]
readListPrec :: ReadPrec [OpenUnitId]
Read, Int -> OpenUnitId -> ShowS
[OpenUnitId] -> ShowS
OpenUnitId -> String
(Int -> OpenUnitId -> ShowS)
-> (OpenUnitId -> String)
-> ([OpenUnitId] -> ShowS)
-> Show OpenUnitId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenUnitId -> ShowS
showsPrec :: Int -> OpenUnitId -> ShowS
$cshow :: OpenUnitId -> String
show :: OpenUnitId -> String
$cshowList :: [OpenUnitId] -> ShowS
showList :: [OpenUnitId] -> ShowS
Show, OpenUnitId -> OpenUnitId -> Bool
(OpenUnitId -> OpenUnitId -> Bool)
-> (OpenUnitId -> OpenUnitId -> Bool) -> Eq OpenUnitId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenUnitId -> OpenUnitId -> Bool
== :: OpenUnitId -> OpenUnitId -> Bool
$c/= :: OpenUnitId -> OpenUnitId -> Bool
/= :: OpenUnitId -> OpenUnitId -> Bool
Eq, Eq OpenUnitId
Eq OpenUnitId =>
(OpenUnitId -> OpenUnitId -> Ordering)
-> (OpenUnitId -> OpenUnitId -> Bool)
-> (OpenUnitId -> OpenUnitId -> Bool)
-> (OpenUnitId -> OpenUnitId -> Bool)
-> (OpenUnitId -> OpenUnitId -> Bool)
-> (OpenUnitId -> OpenUnitId -> OpenUnitId)
-> (OpenUnitId -> OpenUnitId -> OpenUnitId)
-> Ord OpenUnitId
OpenUnitId -> OpenUnitId -> Bool
OpenUnitId -> OpenUnitId -> Ordering
OpenUnitId -> OpenUnitId -> OpenUnitId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OpenUnitId -> OpenUnitId -> Ordering
compare :: OpenUnitId -> OpenUnitId -> Ordering
$c< :: OpenUnitId -> OpenUnitId -> Bool
< :: OpenUnitId -> OpenUnitId -> Bool
$c<= :: OpenUnitId -> OpenUnitId -> Bool
<= :: OpenUnitId -> OpenUnitId -> Bool
$c> :: OpenUnitId -> OpenUnitId -> Bool
> :: OpenUnitId -> OpenUnitId -> Bool
$c>= :: OpenUnitId -> OpenUnitId -> Bool
>= :: OpenUnitId -> OpenUnitId -> Bool
$cmax :: OpenUnitId -> OpenUnitId -> OpenUnitId
max :: OpenUnitId -> OpenUnitId -> OpenUnitId
$cmin :: OpenUnitId -> OpenUnitId -> OpenUnitId
min :: OpenUnitId -> OpenUnitId -> OpenUnitId
Ord, Typeable, Typeable OpenUnitId
Typeable OpenUnitId =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> OpenUnitId -> c OpenUnitId)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c OpenUnitId)
-> (OpenUnitId -> Constr)
-> (OpenUnitId -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c OpenUnitId))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c OpenUnitId))
-> ((forall b. Data b => b -> b) -> OpenUnitId -> OpenUnitId)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r)
-> (forall u. (forall d. Data d => d -> u) -> OpenUnitId -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> OpenUnitId -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId)
-> Data OpenUnitId
OpenUnitId -> Constr
OpenUnitId -> DataType
(forall b. Data b => b -> b) -> OpenUnitId -> OpenUnitId
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OpenUnitId -> u
forall u. (forall d. Data d => d -> u) -> OpenUnitId -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenUnitId
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenUnitId -> c OpenUnitId
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenUnitId)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenUnitId)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenUnitId -> c OpenUnitId
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenUnitId -> c OpenUnitId
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenUnitId
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenUnitId
$ctoConstr :: OpenUnitId -> Constr
toConstr :: OpenUnitId -> Constr
$cdataTypeOf :: OpenUnitId -> DataType
dataTypeOf :: OpenUnitId -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenUnitId)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenUnitId)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenUnitId)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenUnitId)
$cgmapT :: (forall b. Data b => b -> b) -> OpenUnitId -> OpenUnitId
gmapT :: (forall b. Data b => b -> b) -> OpenUnitId -> OpenUnitId
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenUnitId -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OpenUnitId -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> OpenUnitId -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenUnitId -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenUnitId -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenUnitId -> m OpenUnitId
Data)

-- TODO: cache holes?

instance Binary OpenUnitId
instance Structured OpenUnitId
instance NFData OpenUnitId where
  rnf :: OpenUnitId -> ()
rnf (IndefFullUnitId ComponentId
cid OpenModuleSubst
subst) = ComponentId -> ()
forall a. NFData a => a -> ()
rnf ComponentId
cid () -> () -> ()
forall a b. a -> b -> b
`seq` OpenModuleSubst -> ()
forall a. NFData a => a -> ()
rnf OpenModuleSubst
subst
  rnf (DefiniteUnitId DefUnitId
uid) = DefUnitId -> ()
forall a. NFData a => a -> ()
rnf DefUnitId
uid

instance Pretty OpenUnitId where
  pretty :: OpenUnitId -> Doc
pretty (IndefFullUnitId ComponentId
cid OpenModuleSubst
insts)
    -- TODO: arguably a smart constructor to enforce invariant would be
    -- better
    | OpenModuleSubst -> Bool
forall k a. Map k a -> Bool
Map.null OpenModuleSubst
insts = ComponentId -> Doc
forall a. Pretty a => a -> Doc
pretty ComponentId
cid
    | Bool
otherwise = ComponentId -> Doc
forall a. Pretty a => a -> Doc
pretty ComponentId
cid Doc -> Doc -> Doc
<<>> Doc -> Doc
Disp.brackets (OpenModuleSubst -> Doc
dispOpenModuleSubst OpenModuleSubst
insts)
  pretty (DefiniteUnitId DefUnitId
uid) = DefUnitId -> Doc
forall a. Pretty a => a -> Doc
pretty DefUnitId
uid

-- |
--
-- >>> eitherParsec "foobar" :: Either String OpenUnitId
-- Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
--
-- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId
-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))]))
instance Parsec OpenUnitId where
  parsec :: forall (m :: * -> *). CabalParsing m => m OpenUnitId
parsec = m OpenUnitId -> m OpenUnitId
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try m OpenUnitId
parseOpenUnitId m OpenUnitId -> m OpenUnitId -> m OpenUnitId
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (DefUnitId -> OpenUnitId) -> m DefUnitId -> m OpenUnitId
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefUnitId -> OpenUnitId
DefiniteUnitId m DefUnitId
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m DefUnitId
parsec
    where
      parseOpenUnitId :: m OpenUnitId
parseOpenUnitId = do
        ComponentId
cid <- m ComponentId
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m ComponentId
parsec
        OpenModuleSubst
insts <-
          m Char -> m Char -> m OpenModuleSubst -> m OpenModuleSubst
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
P.between
            (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'[')
            (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
']')
            m OpenModuleSubst
forall (m :: * -> *). CabalParsing m => m OpenModuleSubst
parsecOpenModuleSubst
        OpenUnitId -> m OpenUnitId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
insts)

-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (IndefFullUnitId ComponentId
_ OpenModuleSubst
insts) = OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles OpenModuleSubst
insts
openUnitIdFreeHoles OpenUnitId
_ = Set ModuleName
forall a. Set a
Set.empty

-- | Safe constructor from a UnitId.  The only way to do this safely
-- is if the instantiation is provided.
mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId UnitId
uid ComponentId
cid OpenModuleSubst
insts =
  if Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null (OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles OpenModuleSubst
insts)
    then DefUnitId -> OpenUnitId
DefiniteUnitId (UnitId -> DefUnitId
unsafeMkDefUnitId UnitId
uid) -- invariant holds!
    else ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
insts

-----------------------------------------------------------------------
-- DefUnitId

-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
-- with no holes.
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId ComponentId
cid Map ModuleName Module
insts =
  UnitId -> DefUnitId
unsafeMkDefUnitId
    ( String -> UnitId
mkUnitId
        (ComponentId -> String
unComponentId ComponentId
cid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"+" String -> ShowS
forall a. [a] -> [a] -> [a]
++) (Map ModuleName Module -> Maybe String
hashModuleSubst Map ModuleName Module
insts))
    )

-- impose invariant!

-----------------------------------------------------------------------
-- OpenModule

-- | Unlike a 'Module', an 'OpenModule' is either an ordinary
-- module from some unit, OR an 'OpenModuleVar', representing a
-- hole that needs to be filled in.  Substitutions are over
-- module variables.
data OpenModule
  = OpenModule OpenUnitId ModuleName
  | OpenModuleVar ModuleName
  deriving ((forall x. OpenModule -> Rep OpenModule x)
-> (forall x. Rep OpenModule x -> OpenModule) -> Generic OpenModule
forall x. Rep OpenModule x -> OpenModule
forall x. OpenModule -> Rep OpenModule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OpenModule -> Rep OpenModule x
from :: forall x. OpenModule -> Rep OpenModule x
$cto :: forall x. Rep OpenModule x -> OpenModule
to :: forall x. Rep OpenModule x -> OpenModule
Generic, ReadPrec [OpenModule]
ReadPrec OpenModule
Int -> ReadS OpenModule
ReadS [OpenModule]
(Int -> ReadS OpenModule)
-> ReadS [OpenModule]
-> ReadPrec OpenModule
-> ReadPrec [OpenModule]
-> Read OpenModule
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS OpenModule
readsPrec :: Int -> ReadS OpenModule
$creadList :: ReadS [OpenModule]
readList :: ReadS [OpenModule]
$creadPrec :: ReadPrec OpenModule
readPrec :: ReadPrec OpenModule
$creadListPrec :: ReadPrec [OpenModule]
readListPrec :: ReadPrec [OpenModule]
Read, Int -> OpenModule -> ShowS
[OpenModule] -> ShowS
OpenModule -> String
(Int -> OpenModule -> ShowS)
-> (OpenModule -> String)
-> ([OpenModule] -> ShowS)
-> Show OpenModule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenModule -> ShowS
showsPrec :: Int -> OpenModule -> ShowS
$cshow :: OpenModule -> String
show :: OpenModule -> String
$cshowList :: [OpenModule] -> ShowS
showList :: [OpenModule] -> ShowS
Show, OpenModule -> OpenModule -> Bool
(OpenModule -> OpenModule -> Bool)
-> (OpenModule -> OpenModule -> Bool) -> Eq OpenModule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenModule -> OpenModule -> Bool
== :: OpenModule -> OpenModule -> Bool
$c/= :: OpenModule -> OpenModule -> Bool
/= :: OpenModule -> OpenModule -> Bool
Eq, Eq OpenModule
Eq OpenModule =>
(OpenModule -> OpenModule -> Ordering)
-> (OpenModule -> OpenModule -> Bool)
-> (OpenModule -> OpenModule -> Bool)
-> (OpenModule -> OpenModule -> Bool)
-> (OpenModule -> OpenModule -> Bool)
-> (OpenModule -> OpenModule -> OpenModule)
-> (OpenModule -> OpenModule -> OpenModule)
-> Ord OpenModule
OpenModule -> OpenModule -> Bool
OpenModule -> OpenModule -> Ordering
OpenModule -> OpenModule -> OpenModule
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OpenModule -> OpenModule -> Ordering
compare :: OpenModule -> OpenModule -> Ordering
$c< :: OpenModule -> OpenModule -> Bool
< :: OpenModule -> OpenModule -> Bool
$c<= :: OpenModule -> OpenModule -> Bool
<= :: OpenModule -> OpenModule -> Bool
$c> :: OpenModule -> OpenModule -> Bool
> :: OpenModule -> OpenModule -> Bool
$c>= :: OpenModule -> OpenModule -> Bool
>= :: OpenModule -> OpenModule -> Bool
$cmax :: OpenModule -> OpenModule -> OpenModule
max :: OpenModule -> OpenModule -> OpenModule
$cmin :: OpenModule -> OpenModule -> OpenModule
min :: OpenModule -> OpenModule -> OpenModule
Ord, Typeable, Typeable OpenModule
Typeable OpenModule =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> OpenModule -> c OpenModule)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c OpenModule)
-> (OpenModule -> Constr)
-> (OpenModule -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c OpenModule))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c OpenModule))
-> ((forall b. Data b => b -> b) -> OpenModule -> OpenModule)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenModule -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> OpenModule -> r)
-> (forall u. (forall d. Data d => d -> u) -> OpenModule -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> OpenModule -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> OpenModule -> m OpenModule)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenModule -> m OpenModule)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> OpenModule -> m OpenModule)
-> Data OpenModule
OpenModule -> Constr
OpenModule -> DataType
(forall b. Data b => b -> b) -> OpenModule -> OpenModule
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> OpenModule -> u
forall u. (forall d. Data d => d -> u) -> OpenModule -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenModule
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenModule -> c OpenModule
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenModule)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenModule)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenModule -> c OpenModule
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> OpenModule -> c OpenModule
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenModule
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c OpenModule
$ctoConstr :: OpenModule -> Constr
toConstr :: OpenModule -> Constr
$cdataTypeOf :: OpenModule -> DataType
dataTypeOf :: OpenModule -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenModule)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c OpenModule)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenModule)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c OpenModule)
$cgmapT :: (forall b. Data b => b -> b) -> OpenModule -> OpenModule
gmapT :: (forall b. Data b => b -> b) -> OpenModule -> OpenModule
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> OpenModule -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> OpenModule -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> OpenModule -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenModule -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> OpenModule -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> OpenModule -> m OpenModule
Data)

instance Binary OpenModule
instance Structured OpenModule

instance NFData OpenModule where
  rnf :: OpenModule -> ()
rnf (OpenModule OpenUnitId
uid ModuleName
mod_name) = OpenUnitId -> ()
forall a. NFData a => a -> ()
rnf OpenUnitId
uid () -> () -> ()
forall a b. a -> b -> b
`seq` ModuleName -> ()
forall a. NFData a => a -> ()
rnf ModuleName
mod_name
  rnf (OpenModuleVar ModuleName
mod_name) = ModuleName -> ()
forall a. NFData a => a -> ()
rnf ModuleName
mod_name

instance Pretty OpenModule where
  pretty :: OpenModule -> Doc
pretty (OpenModule OpenUnitId
uid ModuleName
mod_name) =
    [Doc] -> Doc
hcat [OpenUnitId -> Doc
forall a. Pretty a => a -> Doc
pretty OpenUnitId
uid, String -> Doc
Disp.text String
":", ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
mod_name]
  pretty (OpenModuleVar ModuleName
mod_name) =
    [Doc] -> Doc
hcat [Char -> Doc
Disp.char Char
'<', ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
mod_name, Char -> Doc
Disp.char Char
'>']

-- |
--
-- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule
-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL"))
instance Parsec OpenModule where
  parsec :: forall (m :: * -> *). CabalParsing m => m OpenModule
parsec = m OpenModule
parsecModuleVar m OpenModule -> m OpenModule -> m OpenModule
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m OpenModule
parsecOpenModule
    where
      parsecOpenModule :: m OpenModule
parsecOpenModule = do
        OpenUnitId
uid <- m OpenUnitId
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m OpenUnitId
parsec
        Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
        ModuleName
mod_name <- m ModuleName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m ModuleName
parsec
        OpenModule -> m OpenModule
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
uid ModuleName
mod_name)

      parsecModuleVar :: m OpenModule
parsecModuleVar = do
        Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'<'
        ModuleName
mod_name <- m ModuleName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m ModuleName
parsec
        Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'>'
        OpenModule -> m OpenModule
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> OpenModule
OpenModuleVar ModuleName
mod_name)

-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
openModuleFreeHoles :: OpenModule -> Set ModuleName
openModuleFreeHoles :: OpenModule -> Set ModuleName
openModuleFreeHoles (OpenModuleVar ModuleName
mod_name) = ModuleName -> Set ModuleName
forall a. a -> Set a
Set.singleton ModuleName
mod_name
openModuleFreeHoles (OpenModule OpenUnitId
uid ModuleName
_n) = OpenUnitId -> Set ModuleName
openUnitIdFreeHoles OpenUnitId
uid

-----------------------------------------------------------------------
-- OpenModuleSubst

-- | An explicit substitution on modules.
--
-- NB: These substitutions are NOT idempotent, for example, a
-- valid substitution is (A -> B, B -> A).
type OpenModuleSubst = Map ModuleName OpenModule

-- | Pretty-print the entries of a module substitution, suitable
-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.
dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc
dispOpenModuleSubst :: OpenModuleSubst -> Doc
dispOpenModuleSubst OpenModuleSubst
subst =
  [Doc] -> Doc
Disp.hcat
    ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
Disp.punctuate Doc
Disp.comma
    ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((ModuleName, OpenModule) -> Doc)
-> [(ModuleName, OpenModule)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, OpenModule) -> Doc
dispOpenModuleSubstEntry (OpenModuleSubst -> [(ModuleName, OpenModule)]
forall k a. Map k a -> [(k, a)]
Map.toAscList OpenModuleSubst
subst)

-- | Pretty-print a single entry of a module substitution.
dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc
dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Doc
dispOpenModuleSubstEntry (ModuleName
k, OpenModule
v) = ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
k Doc -> Doc -> Doc
<<>> Char -> Doc
Disp.char Char
'=' Doc -> Doc -> Doc
<<>> OpenModule -> Doc
forall a. Pretty a => a -> Doc
pretty OpenModule
v

-- | Inverse to 'dispModSubst'.
--
-- @since 2.2
parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst
parsecOpenModuleSubst :: forall (m :: * -> *). CabalParsing m => m OpenModuleSubst
parsecOpenModuleSubst =
  ([(ModuleName, OpenModule)] -> OpenModuleSubst)
-> m [(ModuleName, OpenModule)] -> m OpenModuleSubst
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    (m [(ModuleName, OpenModule)] -> m OpenModuleSubst)
-> (m (ModuleName, OpenModule) -> m [(ModuleName, OpenModule)])
-> m (ModuleName, OpenModule)
-> m OpenModuleSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (ModuleName, OpenModule)
 -> m Char -> m [(ModuleName, OpenModule)])
-> m Char
-> m (ModuleName, OpenModule)
-> m [(ModuleName, OpenModule)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (ModuleName, OpenModule)
-> m Char -> m [(ModuleName, OpenModule)]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
P.sepBy (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
',')
    (m (ModuleName, OpenModule) -> m OpenModuleSubst)
-> m (ModuleName, OpenModule) -> m OpenModuleSubst
forall a b. (a -> b) -> a -> b
$ m (ModuleName, OpenModule)
forall (m :: * -> *). CabalParsing m => m (ModuleName, OpenModule)
parsecOpenModuleSubstEntry

-- | Inverse to 'dispModSubstEntry'.
--
-- @since 2.2
parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule)
parsecOpenModuleSubstEntry :: forall (m :: * -> *). CabalParsing m => m (ModuleName, OpenModule)
parsecOpenModuleSubstEntry =
  do
    ModuleName
k <- m ModuleName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m ModuleName
parsec
    Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'='
    OpenModule
v <- m OpenModule
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m OpenModule
parsec
    (ModuleName, OpenModule) -> m (ModuleName, OpenModule)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
k, OpenModule
v)

-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
-- This is NOT the domain of the substitution.
openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles OpenModuleSubst
insts = [Set ModuleName] -> Set ModuleName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((OpenModule -> Set ModuleName) -> [OpenModule] -> [Set ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map OpenModule -> Set ModuleName
openModuleFreeHoles (OpenModuleSubst -> [OpenModule]
forall k a. Map k a -> [a]
Map.elems OpenModuleSubst
insts))

-----------------------------------------------------------------------
-- Conversions to UnitId

-- | When typechecking, we don't demand that a freshly instantiated
-- 'IndefFullUnitId' be compiled; instead, we just depend on the
-- installed indefinite unit installed at the 'ComponentId'.
abstractUnitId :: OpenUnitId -> UnitId
abstractUnitId :: OpenUnitId -> UnitId
abstractUnitId (DefiniteUnitId DefUnitId
def_uid) = DefUnitId -> UnitId
unDefUnitId DefUnitId
def_uid
abstractUnitId (IndefFullUnitId ComponentId
cid OpenModuleSubst
_) = ComponentId -> UnitId
newSimpleUnitId ComponentId
cid

-- | Take a module substitution and hash it into a string suitable for
-- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',
-- you are responsible for recursively converting 'OpenModule'
-- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".
hashModuleSubst :: Map ModuleName Module -> Maybe String
hashModuleSubst :: Map ModuleName Module -> Maybe String
hashModuleSubst Map ModuleName Module
subst
  | Map ModuleName Module -> Bool
forall k a. Map k a -> Bool
Map.null Map ModuleName Module
subst = Maybe String
forall a. Maybe a
Nothing
  | Bool
otherwise =
      String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> ShowS -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
hashToBase62 (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
mod_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Module -> String
forall a. Pretty a => a -> String
prettyShow Module
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
          | (ModuleName
mod_name, Module
m) <- Map ModuleName Module -> [(ModuleName, Module)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ModuleName Module
subst
          ]