Distribution/Backpack.hs

    {-# 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 Prelude ()
    import Text.PrettyPrint            (hcat)

    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 lossly
    -- represent it as an 'OpenUnitId 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 (Generic, Read, Show, Eq, Ord, Typeable, Data)
    -- TODO: cache holes?

    instance Binary OpenUnitId
    instance Structured OpenUnitId
    instance NFData OpenUnitId where
        rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
        rnf (DefiniteUnitId uid) = rnf uid

    instance Pretty OpenUnitId where
        pretty (IndefFullUnitId cid insts)
            -- TODO: arguably a smart constructor to enforce invariant would be
            -- better
            | Map.null insts = pretty cid
            | otherwise      = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)
        pretty (DefiniteUnitId uid) = pretty 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 = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
          where
            parseOpenUnitId = do
                cid <- parsec
                insts <- P.between (P.char '[') (P.char ']')
                           parsecOpenModuleSubst
                return (IndefFullUnitId cid insts)

    -- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
    openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
    openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
    openUnitIdFreeHoles _ = 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 uid cid insts =
        if Set.null (openModuleSubstFreeHoles insts)
            then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
            else IndefFullUnitId cid insts

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

    -- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
    -- with no holes.
    mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
    mkDefUnitId cid insts =
        unsafeMkDefUnitId (mkUnitId
            (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst 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 (Generic, Read, Show, Eq, Ord, Typeable, Data)

    instance Binary OpenModule
    instance Structured OpenModule

    instance NFData OpenModule where
        rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
        rnf (OpenModuleVar mod_name) = rnf mod_name

    instance Pretty OpenModule where
        pretty (OpenModule uid mod_name) =
            hcat [pretty uid, Disp.text ":", pretty mod_name]
        pretty (OpenModuleVar mod_name) =
            hcat [Disp.char '<', pretty mod_name, Disp.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 = parsecModuleVar <|> parsecOpenModule
          where
            parsecOpenModule = do
                uid <- parsec
                _ <- P.char ':'
                mod_name <- parsec
                return (OpenModule uid mod_name)

            parsecModuleVar = do
                _ <- P.char '<'
                mod_name <- parsec
                _ <- P.char '>'
                return (OpenModuleVar mod_name)

    -- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
    openModuleFreeHoles :: OpenModule -> Set ModuleName
    openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name
    openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles 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 subst
        = Disp.hcat
        . Disp.punctuate Disp.comma
        $ map dispOpenModuleSubstEntry (Map.toAscList subst)

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

    -- | Inverse to 'dispModSubst'.
    --
    -- @since 2.2
    parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst
    parsecOpenModuleSubst = fmap Map.fromList
          . flip P.sepBy (P.char ',')
          $ parsecOpenModuleSubstEntry

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

    -- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
    -- This is NOT the domain of the substitution.
    openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
    openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems 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 (DefiniteUnitId def_uid) = unDefUnitId def_uid
    abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId 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 subst
      | Map.null subst = Nothing
      | otherwise =
          Just . hashToBase62 $
            concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
                   | (mod_name, m) <- Map.toList subst]