Cabal-syntax/src/Distribution/Backpack.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE PatternGuards #-}
   6 {-# LANGUAGE RankNTypes #-}
   7
   8 -- | This module defines the core data types for Backpack.  For more
   9 -- details, see:
  10 --
  11 --  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
  12 module Distribution.Backpack
  13   ( -- * OpenUnitId
  14     OpenUnitId (..)
  15   , openUnitIdFreeHoles
  16   , mkOpenUnitId
  17
  18     -- * DefUnitId
  19   , DefUnitId
  20   , unDefUnitId
  21   , mkDefUnitId
  22
  23     -- * OpenModule
  24   , OpenModule (..)
  25   , openModuleFreeHoles
  26
  27     -- * OpenModuleSubst
  28   , OpenModuleSubst
  29   , dispOpenModuleSubst
  30   , dispOpenModuleSubstEntry
  31   , parsecOpenModuleSubst
  32   , parsecOpenModuleSubstEntry
  33   , openModuleSubstFreeHoles
  34
  35     -- * Conversions to 'UnitId'
  36   , abstractUnitId
  37   , hashModuleSubst
  38   ) where
  39
  40 import Distribution.Compat.Prelude hiding (mod)
  41 import Distribution.Parsec
  42 import Distribution.Pretty
  43 import Text.PrettyPrint (hcat)
  44 import Prelude ()
  45
  46 import qualified Distribution.Compat.CharParsing as P
  47 import qualified Text.PrettyPrint as Disp
  48
  49 import Distribution.ModuleName
  50 import Distribution.Types.ComponentId
  51 import Distribution.Types.Module
  52 import Distribution.Types.UnitId
  53 import Distribution.Utils.Base62
  54
  55 import qualified Data.Map as Map
  56 import qualified Data.Set as Set
  57
  58 -----------------------------------------------------------------------
  59 -- OpenUnitId
  60
  61 -- | An 'OpenUnitId' describes a (possibly partially) instantiated
  62 -- Backpack component, with a description of how the holes are filled
  63 -- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured
  64 -- form that allows for substitution (which fills in holes.) This form
  65 -- of unit cannot be installed. It must first be converted to a
  66 -- 'UnitId'.
  67 --
  68 -- In the absence of Backpack, there are no holes to fill, so any such
  69 -- component always has an empty module substitution; thus we can lossily
  70 -- represent it as a 'DefiniteUnitId uid'.
  71 --
  72 -- For a source component using Backpack, however, there is more
  73 -- structure as components may be parametrized over some signatures, and
  74 -- these \"holes\" may be partially or wholly filled.
  75 --
  76 -- OpenUnitId plays an important role when we are mix-in linking,
  77 -- and is recorded to the installed packaged database for indefinite
  78 -- packages; however, for compiled packages that are fully instantiated,
  79 -- we instantiate 'OpenUnitId' into 'UnitId'.
  80 --
  81 -- For more details see the Backpack spec
  82 -- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
  83 data OpenUnitId
  84   = -- | Identifies a component which may have some unfilled holes;
  85     -- specifying its 'ComponentId' and its 'OpenModuleSubst'.
  86     -- TODO: Invariant that 'OpenModuleSubst' is non-empty?
  87     -- See also the Text instance.
  88     IndefFullUnitId ComponentId OpenModuleSubst
  89   | -- | Identifies a fully instantiated component, which has
  90     -- been compiled and abbreviated as a hash.  The embedded 'UnitId'
  91     -- MUST NOT be for an indefinite component; an 'OpenUnitId'
  92     -- is guaranteed not to have any holes.
  93     DefiniteUnitId DefUnitId
  94   deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
  95
  96 -- TODO: cache holes?
  97
  98 instance Binary OpenUnitId
  99 instance Structured OpenUnitId
 100 instance NFData OpenUnitId where
 101   rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
 102   rnf (DefiniteUnitId uid) = rnf uid
 103
 104 instance Pretty OpenUnitId where
 105   pretty (IndefFullUnitId cid insts)
 106     -- TODO: arguably a smart constructor to enforce invariant would be
 107     -- better
 108     | Map.null insts = pretty cid
 109     | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)
 110   pretty (DefiniteUnitId uid) = pretty uid
 111
 112 -- |
 113 --
 114 -- >>> eitherParsec "foobar" :: Either String OpenUnitId
 115 -- Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
 116 --
 117 -- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId
 118 -- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))]))
 119 instance Parsec OpenUnitId where
 120   parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
 121     where
 122       parseOpenUnitId = do
 123         cid <- parsec
 124         insts <-
 125           P.between
 126             (P.char '[')
 127             (P.char ']')
 128             parsecOpenModuleSubst
 129         return (IndefFullUnitId cid insts)
 130
 131 -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
 132 openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
 133 openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
 134 openUnitIdFreeHoles _ = Set.empty
 135
 136 -- | Safe constructor from a UnitId.  The only way to do this safely
 137 -- is if the instantiation is provided.
 138 mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
 139 mkOpenUnitId uid cid insts =
 140   if Set.null (openModuleSubstFreeHoles insts)
 141     then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
 142     else IndefFullUnitId cid insts
 143
 144 -----------------------------------------------------------------------
 145 -- DefUnitId
 146
 147 -- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
 148 -- with no holes.
 149 mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
 150 mkDefUnitId cid insts =
 151   unsafeMkDefUnitId
 152     ( mkUnitId
 153         (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
 154     )
 155
 156 -- impose invariant!
 157
 158 -----------------------------------------------------------------------
 159 -- OpenModule
 160
 161 -- | Unlike a 'Module', an 'OpenModule' is either an ordinary
 162 -- module from some unit, OR an 'OpenModuleVar', representing a
 163 -- hole that needs to be filled in.  Substitutions are over
 164 -- module variables.
 165 data OpenModule
 166   = OpenModule OpenUnitId ModuleName
 167   | OpenModuleVar ModuleName
 168   deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
 169
 170 instance Binary OpenModule
 171 instance Structured OpenModule
 172
 173 instance NFData OpenModule where
 174   rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
 175   rnf (OpenModuleVar mod_name) = rnf mod_name
 176
 177 instance Pretty OpenModule where
 178   pretty (OpenModule uid mod_name) =
 179     hcat [pretty uid, Disp.text ":", pretty mod_name]
 180   pretty (OpenModuleVar mod_name) =
 181     hcat [Disp.char '<', pretty mod_name, Disp.char '>']
 182
 183 -- |
 184 --
 185 -- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule
 186 -- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL"))
 187 instance Parsec OpenModule where
 188   parsec = parsecModuleVar <|> parsecOpenModule
 189     where
 190       parsecOpenModule = do
 191         uid <- parsec
 192         _ <- P.char ':'
 193         mod_name <- parsec
 194         return (OpenModule uid mod_name)
 195
 196       parsecModuleVar = do
 197         _ <- P.char '<'
 198         mod_name <- parsec
 199         _ <- P.char '>'
 200         return (OpenModuleVar mod_name)
 201
 202 -- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
 203 openModuleFreeHoles :: OpenModule -> Set ModuleName
 204 openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name
 205 openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid
 206
 207 -----------------------------------------------------------------------
 208 -- OpenModuleSubst
 209
 210 -- | An explicit substitution on modules.
 211 --
 212 -- NB: These substitutions are NOT idempotent, for example, a
 213 -- valid substitution is (A -> B, B -> A).
 214 type OpenModuleSubst = Map ModuleName OpenModule
 215
 216 -- | Pretty-print the entries of a module substitution, suitable
 217 -- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.
 218 dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc
 219 dispOpenModuleSubst subst =
 220   Disp.hcat
 221     . Disp.punctuate Disp.comma
 222     $ map dispOpenModuleSubstEntry (Map.toAscList subst)
 223
 224 -- | Pretty-print a single entry of a module substitution.
 225 dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc
 226 dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v
 227
 228 -- | Inverse to 'dispModSubst'.
 229 --
 230 -- @since 2.2
 231 parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst
 232 parsecOpenModuleSubst =
 233   fmap Map.fromList
 234     . flip P.sepBy (P.char ',')
 235     $ parsecOpenModuleSubstEntry
 236
 237 -- | Inverse to 'dispModSubstEntry'.
 238 --
 239 -- @since 2.2
 240 parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule)
 241 parsecOpenModuleSubstEntry =
 242   do
 243     k <- parsec
 244     _ <- P.char '='
 245     v <- parsec
 246     return (k, v)
 247
 248 -- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
 249 -- This is NOT the domain of the substitution.
 250 openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
 251 openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts))
 252
 253 -----------------------------------------------------------------------
 254 -- Conversions to UnitId
 255
 256 -- | When typechecking, we don't demand that a freshly instantiated
 257 -- 'IndefFullUnitId' be compiled; instead, we just depend on the
 258 -- installed indefinite unit installed at the 'ComponentId'.
 259 abstractUnitId :: OpenUnitId -> UnitId
 260 abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
 261 abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
 262
 263 -- | Take a module substitution and hash it into a string suitable for
 264 -- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',
 265 -- you are responsible for recursively converting 'OpenModule'
 266 -- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".
 267 hashModuleSubst :: Map ModuleName Module -> Maybe String
 268 hashModuleSubst subst
 269   | Map.null subst = Nothing
 270   | otherwise =
 271       Just . hashToBase62 $
 272         concat
 273           [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
 274           | (mod_name, m) <- Map.toList subst
 275           ]