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