Cabal-syntax/src/Distribution/Backpack.hs

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