Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • bgamari/cabal-build-test
  • samuela/cabal-build-test
  • emilypi/cabal-build-test
3 results
Show changes
Showing
with 0 additions and 3884 deletions
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Backpack.FullUnitId (
FullUnitId(..),
FullDb,
expandOpenUnitId,
expandUnitId
) where
import Distribution.Backpack
import Distribution.Types.ComponentId
import Distribution.Compat.Prelude
-- Unlike OpenUnitId, which could direct to a UnitId.
data FullUnitId = FullUnitId ComponentId OpenModuleSubst
deriving (Show, Generic)
type FullDb = DefUnitId -> FullUnitId
expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId
expandOpenUnitId _db (IndefFullUnitId cid subst)
= FullUnitId cid subst
expandOpenUnitId db (DefiniteUnitId uid)
= expandUnitId db uid
expandUnitId :: FullDb -> DefUnitId -> FullUnitId
expandUnitId db uid = db uid
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.Id(
computeComponentId,
computeCompatPackageKey,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Distribution.Simple.Compiler hiding (Flag)
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.Setup as Setup
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Types.UnitId
import Distribution.Types.MungedPackageName
import Distribution.Utils.Base62
import Distribution.Version
import Distribution.Pretty
( prettyShow )
import Distribution.Parsec ( simpleParsec )
-- | This method computes a default, "good enough" 'ComponentId'
-- for a package. The intent is that cabal-install (or the user) will
-- specify a more detailed IPID via the @--ipid@ flag if necessary.
computeComponentId
:: Bool -- deterministic mode
-> Flag String
-> Flag ComponentId
-> PackageIdentifier
-> ComponentName
-- This is used by cabal-install's legacy codepath
-> Maybe ([ComponentId], FlagAssignment)
-> ComponentId
computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =
-- show is found to be faster than intercalate and then replacement of
-- special character used in intercalating. We cannot simply hash by
-- doubly concating list, as it just flatten out the nested list, so
-- different sources can produce same hash
let hash_suffix
| Just (dep_ipids, flags) <- mb_details
= "-" ++ hashToBase62
-- For safety, include the package + version here
-- for GHC 7.10, where just the hash is used as
-- the package key
( prettyShow pid
++ show dep_ipids
++ show flags )
| otherwise = ""
generated_base = prettyShow pid ++ hash_suffix
explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env
(toPathTemplate cid0))
-- Hack to reuse install dirs machinery
-- NB: no real IPID available at this point
where env = packageTemplateEnv pid (mkUnitId "")
actual_base = case mb_ipid of
Flag ipid0 -> explicit_base ipid0
NoFlag | deterministic -> prettyShow pid
| otherwise -> generated_base
in case mb_cid of
Flag cid -> cid
NoFlag -> mkComponentId $ actual_base
++ (case componentNameString cname of
Nothing -> ""
Just s -> "-" ++ unUnqualComponentName s)
-- | In GHC 8.0, the string we pass to GHC to use for symbol
-- names for a package can be an arbitrary, IPID-compatible string.
-- However, prior to GHC 8.0 there are some restrictions on what
-- format this string can be (due to how ghc-pkg parsed the key):
--
-- 1. In GHC 7.10, the string had either be of the form
-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated
-- prefix and ABCD is two base-64 encoded 64-bit integers,
-- or a GHC 7.8 style identifier.
--
-- 2. In GHC 7.8, the string had to be a valid package identifier
-- like foo-0.1.
--
-- So, the problem is that Cabal, in general, has a general IPID,
-- but needs to figure out a package key / package ID that the
-- old ghc-pkg will actually accept. But there's an EVERY WORSE
-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx
-- as if it were a package identifier, which means it will SILENTLY
-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)
-- So we must CONNIVE to ensure that we don't pick something that
-- looks like this.
--
-- So this function attempts to define a mapping into the old formats.
--
-- The mapping for GHC 7.8 and before:
--
-- * We use the *compatibility* package name and version. For
-- public libraries this is just the package identifier; for
-- internal libraries, it's something like "z-pkgname-z-libname-0.1".
-- See 'computeCompatPackageName' for more details.
--
-- The mapping for GHC 7.10:
--
-- * For CLibName:
-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would
-- validly parse as a package key, we pass "ABCDEF". (NB: not
-- all hashes parse this way, because GHC 7.10 mandated that
-- these hashes be two base-62 encoded 64 bit integers),
-- but hashes that Cabal generated using 'computeComponentId'
-- are guaranteed to have this form.
--
-- If it is not of this form, we rehash the IPID into the
-- correct form and pass that.
--
-- * For sub-components, we rehash the IPID into the correct format
-- and pass that.
--
computeCompatPackageKey
:: Compiler
-> MungedPackageName
-> Version
-> UnitId
-> String
computeCompatPackageKey comp pkg_name pkg_version uid
| not (packageKeySupported comp) =
prettyShow pkg_name ++ "-" ++ prettyShow pkg_version
| not (unifiedIPIDRequired comp) =
let str = unUnitId uid -- assume no Backpack support
mb_verbatim_key
= case simpleParsec str :: Maybe PackageId of
-- Something like 'foo-0.1', use it verbatim.
-- (NB: hash tags look like tags, so they are parsed,
-- so the extra equality check tests if a tag was dropped.)
Just pid0 | prettyShow pid0 == str -> Just str
_ -> Nothing
mb_truncated_key
= let cand = reverse (takeWhile isAlphaNum (reverse str))
in if length cand == 22 && all isAlphaNum cand
then Just cand
else Nothing
rehashed_key = hashToBase62 str
in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)
| otherwise = prettyShow uid
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.LinkedComponent (
LinkedComponent(..),
lc_insts,
lc_uid,
lc_cid,
lc_pkgid,
toLinkedComponent,
toLinkedComponents,
dispLinkedComponent,
LinkedComponentMap,
extendLinkedComponentMap,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
import Distribution.Backpack
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ConfiguredComponent
import Distribution.Backpack.ModuleShape
import Distribution.Backpack.PreModuleShape
import Distribution.Backpack.ModuleScope
import Distribution.Backpack.UnifyM
import Distribution.Backpack.MixLink
import Distribution.Utils.MapAccum
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentName
import Distribution.Types.ModuleRenaming
import Distribution.Types.IncludeRenaming
import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Package
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Verbosity
import Distribution.Utils.LogProgress
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Traversable
( mapM )
import Distribution.Pretty (pretty)
import Text.PrettyPrint
import Data.Either
-- | A linked component is a component that has been mix-in linked, at
-- which point we have determined how all the dependencies of the
-- component are explicitly instantiated (in the form of an OpenUnitId).
-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which
-- is then instantiated into 'ReadyComponent'.
data LinkedComponent
= LinkedComponent {
-- | Uniquely identifies linked component
lc_ann_id :: AnnotatedId ComponentId,
-- | Corresponds to 'cc_component'.
lc_component :: Component,
-- | @build-tools@ and @build-tool-depends@ dependencies.
-- Corresponds to 'cc_exe_deps'.
lc_exe_deps :: [AnnotatedId OpenUnitId],
-- | Is this the public library of a package? Corresponds to
-- 'cc_public'.
lc_public :: Bool,
-- | Corresponds to 'cc_includes', but (1) this does not contain
-- includes of signature packages (packages with no exports),
-- and (2) the 'ModuleRenaming' for requirements (stored in
-- 'IncludeRenaming') has been removed, as it is reflected in
-- 'OpenUnitId'.)
lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
-- | Like 'lc_includes', but this specifies includes on
-- signature packages which have no exports.
lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
-- | The module shape computed by mix-in linking. This is
-- newly computed from 'ConfiguredComponent'
lc_shape :: ModuleShape
}
-- | Uniquely identifies a 'LinkedComponent'. Corresponds to
-- 'cc_cid'.
lc_cid :: LinkedComponent -> ComponentId
lc_cid = ann_id . lc_ann_id
-- | Corresponds to 'cc_pkgid'.
lc_pkgid :: LinkedComponent -> PackageId
lc_pkgid = ann_pid . lc_ann_id
-- | The 'OpenUnitId' of this component in the "default" instantiation.
-- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated
-- (e.g., there is no 'ModSubst' instance for them).
lc_uid :: LinkedComponent -> OpenUnitId
lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc
-- | The instantiation of 'lc_uid'; this always has the invariant
-- that it is a mapping from a module name @A@ to @<A>@ (the hole A).
lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]
lc_insts lc = [ (req, OpenModuleVar req)
| req <- Set.toList (modShapeRequires (lc_shape lc)) ]
dispLinkedComponent :: LinkedComponent -> Doc
dispLinkedComponent lc =
hang (text "unit" <+> pretty (lc_uid lc)) 4 $
vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)
| incl <- lc_includes lc ]
$+$
vcat [ text "signature include" <+> pretty (ci_id incl)
| incl <- lc_sig_includes lc ]
$+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))
instance Package LinkedComponent where
packageId = lc_pkgid
toLinkedComponent
:: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> ConfiguredComponent
-> LogProgress LinkedComponent
toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
cc_ann_id = aid@AnnotatedId { ann_id = this_cid },
cc_component = component,
cc_exe_deps = exe_deps,
cc_public = is_public,
cc_includes = cid_includes
} = do
let
-- The explicitly specified requirements, provisions and
-- reexports from the Cabal file. These are only non-empty for
-- libraries; everything else is trivial.
(src_reqs :: [ModuleName],
src_provs :: [ModuleName],
src_reexports :: [ModuleReexport]) =
case component of
CLib lib -> (signatures lib,
exposedModules lib,
reexportedModules lib)
_ -> ([], [], [])
src_hidden = otherModules (componentBuildInfo component)
-- Take each included ComponentId and resolve it into an
-- *unlinked* unit identity. We will use unification (relying
-- on the ModuleShape) to resolve these into linked identities.
unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i
| ComponentInclude dep_aid rns i <- cid_includes ]
lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
lookupUid cid = fromMaybe (error "linkComponent: lookupUid")
(Map.lookup cid pkg_map)
let orErr (Right x) = return x
orErr (Left [err]) = dieProgress err
orErr (Left errs) = do
dieProgress (vcat (intersperse (text "") -- double newline!
[ hang (text "-") 2 err | err <- errs]))
-- Pre-shaping
let pre_shape = mixLinkPreModuleShape $
PreModuleShape {
preModShapeProvides = Set.fromList (src_provs ++ src_hidden),
preModShapeRequires = Set.fromList src_reqs
} : [ renamePreModuleShape (toPreModuleShape sh) rns
| ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ]
reqs = preModShapeRequires pre_shape
insts = [ (req, OpenModuleVar req)
| req <- Set.toList reqs ]
this_uid = IndefFullUnitId this_cid . Map.fromList $ insts
-- OK, actually do unification
-- TODO: the unification monad might return errors, in which
-- case we have to deal. Use monadic bind for now.
(linked_shape0 :: ModuleScope,
linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],
linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming])
<- orErr $ runUnifyM verbosity this_cid db $ do
-- The unification monad is implemented using mutable
-- references. Thus, we must convert our *pure* data
-- structures into mutable ones to perform unification.
let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod from m = do
m_u <- convertModule (OpenModule this_uid m)
return (Map.singleton m [WithSource (from m) m_u], Map.empty)
-- Handle 'exposed-modules'
exposed_mod_shapes_u <- mapM (convertMod FromExposedModules) src_provs
-- Handle 'other-modules'
other_mod_shapes_u <- mapM (convertMod FromOtherModules) src_hidden
-- Handle 'signatures'
let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
convertReq req = do
req_u <- convertModule (OpenModuleVar req)
return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])
req_shapes_u <- mapM convertReq src_reqs
-- Handle 'mixins'
(incl_shapes_u, all_includes_u) <- fmap unzip (mapM convertInclude unlinked_includes)
failIfErrs -- Prevent error cascade
-- Mix-in link everything! mixLink is the real workhorse.
shape_u <- mixLink $ exposed_mod_shapes_u
++ other_mod_shapes_u
++ req_shapes_u
++ incl_shapes_u
-- src_reqs_u <- mapM convertReq src_reqs
-- Read out all the final results by converting back
-- into a pure representation.
let convertIncludeU (ComponentInclude dep_aid rns i) = do
uid <- convertUnitIdU (ann_id dep_aid)
return (ComponentInclude {
ci_ann_id = dep_aid { ann_id = uid },
ci_renaming = rns,
ci_implicit = i
})
shape <- convertModuleScopeU shape_u
let (includes_u, sig_includes_u) = partitionEithers all_includes_u
incls <- mapM convertIncludeU includes_u
sig_incls <- mapM convertIncludeU sig_includes_u
return (shape, incls, sig_incls)
let isNotLib (CLib _) = False
isNotLib _ = True
when (not (Set.null reqs) && isNotLib component) $
dieProgress $
hang (text "Non-library component has unfilled requirements:")
4 (vcat [pretty req | req <- Set.toList reqs])
-- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg
-- won't allow it (since someone could directly synthesize
-- an 'InstalledPackageInfo' that violates abstraction.)
-- Though, maybe it should be relaxed?
let src_hidden_set = Set.fromList src_hidden
linked_shape = linked_shape0 {
modScopeProvides =
-- Would rather use withoutKeys but need BC
Map.filterWithKey
(\k _ -> not (k `Set.member` src_hidden_set))
(modScopeProvides linked_shape0)
}
-- OK, compute the reexports
-- TODO: This code reports the errors for reexports one reexport at
-- a time. Better to collect them all up and report them all at
-- once.
let hdl :: [Either Doc a] -> LogProgress [a]
hdl es =
case partitionEithers es of
([], rs) -> return rs
(ls, _) ->
dieProgress $
hang (text "Problem with module re-exports:") 2
(vcat [hang (text "-") 2 l | l <- ls])
reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do
case Map.lookup from (modScopeProvides linked_shape) of
Just cands@(x0:xs0) -> do
-- Make sure there is at least one candidate
(x, xs) <-
case mb_pn of
Just pn ->
let matches_pn (FromMixins pn' _ _) = pn == pn'
matches_pn (FromBuildDepends pn' _) = pn == pn'
matches_pn (FromExposedModules _) = pn == packageName this_pid
matches_pn (FromOtherModules _) = pn == packageName this_pid
matches_pn (FromSignatures _) = pn == packageName this_pid
in case filter (matches_pn . getSource) cands of
(x1:xs1) -> return (x1, xs1)
_ -> Left (brokenReexportMsg reex)
Nothing -> return (x0, xs0)
-- Test that all the candidates are consistent
case filter (\x' -> unWithSource x /= unWithSource x') xs of
[] -> return ()
_ -> Left $ ambiguousReexportMsg reex x xs
return (to, unWithSource x)
_ ->
Left (brokenReexportMsg reex)
-- TODO: maybe check this earlier; it's syntactically obvious.
let build_reexports m (k, v)
| Map.member k m =
dieProgress $ hsep
[ text "Module name ", pretty k, text " is exported multiple times." ]
| otherwise = return (Map.insert k v m)
provs <- foldM build_reexports Map.empty $
-- TODO: doublecheck we have checked for
-- src_provs duplicates already!
[ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++
reexports_list
let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))
-- See Note Note [Signature package special case]
let (linked_includes, linked_sig_includes)
| Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])
| otherwise = (linked_includes0, linked_sig_includes0)
return $ LinkedComponent {
lc_ann_id = aid,
lc_component = component,
lc_public = is_public,
-- These must be executables
lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps,
lc_shape = final_linked_shape,
lc_includes = linked_includes,
lc_sig_includes = linked_sig_includes
}
-- Note [Signature package special case]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Suppose we have p-indef, which depends on str-sig and inherits
-- the hole from that signature package. When we instantiate p-indef,
-- it's a bit pointless to also go ahead and build str-sig, because
-- str-sig cannot possibly have contributed any code to the package
-- in question. Furthermore, because the signature was inherited to
-- p-indef, if we test matching against p-indef, we also have tested
-- matching against p-sig. In fact, skipping p-sig is *mandatory*,
-- because p-indef may have thinned it (so that an implementation may
-- match p-indef but not p-sig.)
--
-- However, suppose that we have a package which mixes together str-sig
-- and str-bytestring, with the intent of *checking* that str-sig is
-- implemented by str-bytestring. Here, it's quite important to
-- build an instantiated str-sig, since that is the only way we will
-- actually end up testing if the matching works. Note that this
-- admonition only applies if the package has NO requirements; if it
-- has any requirements, we will typecheck it as an indefinite
-- package, at which point the signature includes will be passed to
-- GHC who will in turn actually do the checking to make sure they
-- are instantiated correctly.
-- Handle mix-in linking for components. In the absence of Backpack,
-- every ComponentId gets converted into a UnitId by way of SimpleUnitId.
toLinkedComponents
:: Verbosity
-> FullDb
-> PackageId
-> LinkedComponentMap
-> [ConfiguredComponent]
-> LogProgress [LinkedComponent]
toLinkedComponents verbosity db this_pid lc_map0 comps
= fmap snd (mapAccumM go lc_map0 comps)
where
go :: Map ComponentId (OpenUnitId, ModuleShape)
-> ConfiguredComponent
-> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
go lc_map cc = do
lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $
toLinkedComponent verbosity db this_pid lc_map cc
return (extendLinkedComponentMap lc lc_map, lc)
type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)
extendLinkedComponentMap :: LinkedComponent
-> LinkedComponentMap
-> LinkedComponentMap
extendLinkedComponentMap lc m =
Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m
brokenReexportMsg :: ModuleReexport -> Doc
brokenReexportMsg (ModuleReexport (Just pn) from _to) =
vcat [ text "The package" <+> quotes (pretty pn)
, text "does not export a module" <+> quotes (pretty from) ]
brokenReexportMsg (ModuleReexport Nothing from _to) =
vcat [ text "The module" <+> quotes (pretty from)
, text "is not exported by any suitable package."
, text "It occurs in neither the 'exposed-modules' of this package,"
, text "nor any of its 'build-depends' dependencies." ]
ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys =
vcat [ text "Ambiguous reexport" <+> quotes (pretty from)
, hang (text "It could refer to either:") 2
(vcat (msg : msgs))
, help_msg mb_pn ]
where
msg = text " " <+> displayModuleWithSource y1
msgs = [text "or" <+> displayModuleWithSource y | y <- ys]
help_msg Nothing =
-- TODO: This advice doesn't help if the ambiguous exports
-- come from a package named the same thing
vcat [ text "The ambiguity can be resolved by qualifying the"
, text "re-export with a package name."
, text "The syntax is 'packagename:ModuleName [as NewName]'." ]
-- Qualifying won't help that much.
help_msg (Just _) =
vcat [ text "The ambiguity can be resolved by using the"
, text "mixins field to rename one of the module"
, text "names differently." ]
displayModuleWithSource y
= vcat [ quotes (pretty (unWithSource y))
, text "brought into scope by" <+>
dispModuleSource (getSource y)
]
{-# LANGUAGE NondecreasingIndentation #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.MixLink (
mixLink,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Backpack
import Distribution.Backpack.UnifyM
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ModuleScope
import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.ModuleName
import Distribution.Pretty
import Distribution.Types.ComponentId
import Text.PrettyPrint
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Foldable as F
-----------------------------------------------------------------------
-- Linking
-- | Given to scopes of provisions and requirements, link them together.
mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink scopes = do
let provs = Map.unionsWith (++) (map fst scopes)
-- Invariant: any identically named holes refer to same mutable cell
reqs = Map.unionsWith (++) (map snd scopes)
filled = Map.intersectionWithKey linkProvision provs reqs
F.sequenceA_ filled
let remaining = Map.difference reqs filled
return (provs, remaining)
-- | Link a list of possibly provided modules to a single
-- requirement. This applies a side-condition that all
-- of the provided modules at the same name are *actually*
-- the same module.
linkProvision :: ModuleName
-> [ModuleWithSourceU s] -- provs
-> [ModuleWithSourceU s] -- reqs
-> UnifyM s [ModuleWithSourceU s]
linkProvision mod_name ret@(prov:provs) (req:reqs) = do
-- TODO: coalesce all the non-unifying modules together
forM_ provs $ \prov' -> do
-- Careful: read it out BEFORE unifying, because the
-- unification algorithm preemptively unifies modules
mod <- convertModuleU (unWithSource prov)
mod' <- convertModuleU (unWithSource prov')
r <- unify prov prov'
case r of
Just () -> return ()
Nothing -> do
addErr $
text "Ambiguous module" <+> quotes (pretty mod_name) $$
text "It could refer to" <+>
( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$
text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$
link_doc
mod <- convertModuleU (unWithSource prov)
req_mod <- convertModuleU (unWithSource req)
self_cid <- fmap unify_self_cid getUnifEnv
case mod of
OpenModule (IndefFullUnitId cid _) _
| cid == self_cid -> addErr $
text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+>
in_scope_by (getSource req) $$
text "with locally defined module" <+> in_scope_by (getSource prov) $$
text "as this would create a cyclic dependency, which GHC does not support." $$
text "Try moving this module to a separate library, e.g.," $$
text "create a new stanza: library 'sublib'."
_ -> return ()
r <- unify prov req
case r of
Just () -> return ()
Nothing -> do
-- TODO: Record and report WHERE the bad constraint came from
addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$
nest 4 (text "Expected:" <+> pretty mod $$
text "Actual: " <+> pretty req_mod) $$
parens (text "This can occur if an exposed module of" <+>
text "a libraries shares a name with another module.") $$
link_doc
return ret
where
unify s1 s2 = tryM $ addErrContext short_link_doc
$ unifyModule (unWithSource s1) (unWithSource s2)
in_scope_by s = text "brought into scope by" <+> dispModuleSource s
short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name)
link_doc = text "While filling requirements of" <+> reqs_doc
reqs_doc
| null reqs = dispModuleSource (getSource req)
| otherwise = ( text " " <+> dispModuleSource (getSource req) $$
vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs])
linkProvision _ _ _ = error "linkProvision"
-----------------------------------------------------------------------
-- The unification algorithm
-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588
-- which is a translation from Huet's thesis.
unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId uid1_u uid2_u
| uid1_u == uid2_u = return ()
| otherwise = do
xuid1 <- liftST $ UnionFind.find uid1_u
xuid2 <- liftST $ UnionFind.find uid2_u
case (xuid1, xuid2) of
(UnitIdThunkU u1, UnitIdThunkU u2)
| u1 == u2 -> return ()
| otherwise ->
failWith $ hang (text "Couldn't match unit IDs:") 4
(text " " <+> pretty u1 $$
text "and" <+> pretty u2)
(UnitIdThunkU uid1, UnitIdU _ cid2 insts2)
-> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u
(UnitIdU _ cid1 insts1, UnitIdThunkU uid2)
-> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u
(UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2)
-> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
unifyThunkWith :: ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do
db <- fmap unify_db getUnifEnv
let FullUnitId cid2 insts2' = expandUnitId db uid2
insts2 <- convertModuleSubst insts2'
unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
unifyInner :: ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do
when (cid1 /= cid2) $
-- TODO: if we had a package identifier, could be an
-- easier to understand error message.
failWith $
hang (text "Couldn't match component IDs:") 4
(text " " <+> pretty cid1 $$
text "and" <+> pretty cid2)
-- The KEY STEP which makes this a Huet-style unification
-- algorithm. (Also a payoff of using union-find.)
-- We can build infinite unit IDs this way, which is necessary
-- for support mutual recursion. NB: union keeps the SECOND
-- descriptor, so we always arrange for a UnitIdThunkU to live
-- there.
liftST $ UnionFind.union uid1_u uid2_u
F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2
-- | Imperatively unify two modules.
unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule mod1_u mod2_u
| mod1_u == mod2_u = return ()
| otherwise = do
mod1 <- liftST $ UnionFind.find mod1_u
mod2 <- liftST $ UnionFind.find mod2_u
case (mod1, mod2) of
(ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u
(_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u
(ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do
when (mod_name1 /= mod_name2) $
failWith $
hang (text "Cannot match module names") 4 $
text " " <+> pretty mod_name1 $$
text "and" <+> pretty mod_name2
-- NB: this is not actually necessary (because we'll
-- detect loops eventually in 'unifyUnitId'), but it
-- seems harmless enough
liftST $ UnionFind.union mod1_u mod2_u
unifyUnitId uid1 uid2
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
-- | A type class 'ModSubst' for objects which can have 'ModuleSubst'
-- applied to them.
--
-- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModSubst (
ModSubst(..),
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Backpack
import Distribution.ModuleName
import qualified Data.Map as Map
import qualified Data.Set as Set
-- | Applying module substitutions to semantic objects.
class ModSubst a where
-- In notation, substitution is postfix, which implies
-- putting it on the right hand side, but for partial
-- application it's more convenient to have it on the left
-- hand side.
modSubst :: OpenModuleSubst -> a -> a
instance ModSubst OpenModule where
modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name
modSubst subst mod@(OpenModuleVar mod_name)
| Just mod' <- Map.lookup mod_name subst = mod'
| otherwise = mod
instance ModSubst OpenUnitId where
modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)
modSubst _subst uid = uid
instance ModSubst (Set ModuleName) where
modSubst subst reqs
= Set.union (Set.difference reqs (Map.keysSet subst))
(openModuleSubstFreeHoles subst)
-- Substitutions are functorial. NB: this means that
-- there is an @instance 'ModSubst' 'ModuleSubst'@!
instance ModSubst a => ModSubst (Map k a) where
modSubst subst = fmap (modSubst subst)
instance ModSubst a => ModSubst [a] where
modSubst subst = fmap (modSubst subst)
instance ModSubst a => ModSubst (k, a) where
modSubst subst (x,y) = (x, modSubst subst y)
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModuleScope (
-- * Module scopes
ModuleScope(..),
ModuleProvides,
ModuleRequires,
ModuleSource(..),
dispModuleSource,
WithSource(..),
unWithSource,
getSource,
ModuleWithSource,
emptyModuleScope,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.ModuleName
import Distribution.Types.IncludeRenaming
import Distribution.Types.PackageName
import Distribution.Types.ComponentName
import Distribution.Types.LibraryName
import Distribution.Pretty
import Distribution.Backpack
import Distribution.Backpack.ModSubst
import qualified Data.Map as Map
import Text.PrettyPrint
-----------------------------------------------------------------------
-- Module scopes
-- Why is ModuleProvides so complicated? The basic problem is that
-- we want to support this:
--
-- package p where
-- include q (A)
-- include r (A)
-- module B where
-- import "q" A
-- import "r" A
--
-- Specifically, in Cabal today it is NOT an error have two modules in
-- scope with the same identifier. So we need to preserve this for
-- Backpack. The modification is that an ambiguous module name is
-- OK... as long as it is NOT used to fill a requirement!
--
-- So as a first try, we might try deferring unifying provisions that
-- are being glommed together, and check for equality after the fact.
-- But this doesn't work, because what if a multi-module provision
-- is used to fill a requirement?! So you do the equality test
-- IMMEDIATELY before a requirement fill happens... or never at all.
--
-- Alternate strategy: go ahead and unify, and then if it is revealed
-- that some requirements got filled "out-of-thin-air", error.
-- | A 'ModuleScope' describes the modules and requirements that
-- are in-scope as we are processing a Cabal package. Unlike
-- a 'ModuleShape', there may be multiple modules in scope at
-- the same 'ModuleName'; this is only an error if we attempt
-- to use those modules to fill a requirement. A 'ModuleScope'
-- can influence the 'ModuleShape' via a reexport.
data ModuleScope = ModuleScope {
modScopeProvides :: ModuleProvides,
modScopeRequires :: ModuleRequires
}
-- | An empty 'ModuleScope'.
emptyModuleScope :: ModuleScope
emptyModuleScope = ModuleScope Map.empty Map.empty
-- | Every 'Module' in scope at a 'ModuleName' is annotated with
-- the 'PackageName' it comes from.
type ModuleProvides = Map ModuleName [ModuleWithSource]
-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m
type ModuleRequires = Map ModuleName [ModuleWithSource]
-- TODO: consider newtping the two types above.
-- | Description of where a module participating in mixin linking came
-- from.
data ModuleSource
= FromMixins PackageName ComponentName IncludeRenaming
| FromBuildDepends PackageName ComponentName
| FromExposedModules ModuleName
| FromOtherModules ModuleName
| FromSignatures ModuleName
-- We don't have line numbers, but if we did, we'd want to record that
-- too
-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg
dispModuleSource :: ModuleSource -> Doc
dispModuleSource (FromMixins pn cn incls)
= text "mixins:" <+> dispComponent pn cn <+> pretty incls
dispModuleSource (FromBuildDepends pn cn)
= text "build-depends:" <+> dispComponent pn cn
dispModuleSource (FromExposedModules m)
= text "exposed-modules:" <+> pretty m
dispModuleSource (FromOtherModules m)
= text "other-modules:" <+> pretty m
dispModuleSource (FromSignatures m)
= text "signatures:" <+> pretty m
-- Dependency
dispComponent :: PackageName -> ComponentName -> Doc
dispComponent pn cn =
-- NB: This syntax isn't quite the source syntax, but it
-- should be clear enough. To do source syntax, we'd
-- need to know what the package we're linking is.
case cn of
CLibName LMainLibName -> pretty pn
CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn
-- Case below shouldn't happen
_ -> pretty pn <+> parens (pretty cn)
-- | An 'OpenModule', annotated with where it came from in a Cabal file.
data WithSource a = WithSource ModuleSource a
deriving (Functor, Foldable, Traversable)
unWithSource :: WithSource a -> a
unWithSource (WithSource _ x) = x
getSource :: WithSource a -> ModuleSource
getSource (WithSource s _) = s
type ModuleWithSource = WithSource OpenModule
instance ModSubst a => ModSubst (WithSource a) where
modSubst subst (WithSource s m) = WithSource s (modSubst subst m)
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModuleShape (
-- * Module shapes
ModuleShape(..),
emptyModuleShape,
shapeInstalledPackage,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
import Distribution.ModuleName
import Distribution.InstalledPackageInfo as IPI
import Distribution.Backpack.ModSubst
import Distribution.Backpack
import qualified Data.Map as Map
import qualified Data.Set as Set
-----------------------------------------------------------------------
-- Module shapes
-- | A 'ModuleShape' describes the provisions and requirements of
-- a library. We can extract a 'ModuleShape' from an
-- 'InstalledPackageInfo'.
data ModuleShape = ModuleShape {
modShapeProvides :: OpenModuleSubst,
modShapeRequires :: Set ModuleName
}
deriving (Eq, Show, Generic, Typeable)
instance Binary ModuleShape
instance Structured ModuleShape
instance ModSubst ModuleShape where
modSubst subst (ModuleShape provs reqs)
= ModuleShape (modSubst subst provs) (modSubst subst reqs)
-- | The default module shape, with no provisions and no requirements.
emptyModuleShape :: ModuleShape
emptyModuleShape = ModuleShape Map.empty Set.empty
-- Food for thought: suppose we apply the Merkel tree optimization.
-- Imagine this situation:
--
-- component p
-- signature H
-- module P
-- component h
-- module H
-- component a
-- signature P
-- module A
-- component q(P)
-- include p
-- include h
-- component r
-- include q (P)
-- include p (P) requires (H)
-- include h (H)
-- include a (A) requires (P)
--
-- Component r should not have any conflicts, since after mix-in linking
-- the two P imports will end up being the same, so we can properly
-- instantiate it. But to know that q's P is p:P instantiated with h:H,
-- we have to be able to expand its unit id. Maybe we can expand it
-- lazily but in some cases it will need to be expanded.
--
-- FWIW, the way that GHC handles this is by improving unit IDs as
-- soon as it sees an improved one in the package database. This
-- is a bit disgusting.
shapeInstalledPackage :: IPI.InstalledPackageInfo -> ModuleShape
shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs
where
uid = installedOpenUnitId ipi
provs = map shapeExposedModule (IPI.exposedModules ipi)
reqs = requiredSignatures ipi
shapeExposedModule (IPI.ExposedModule mod_name Nothing)
= (mod_name, OpenModule uid mod_name)
shapeExposedModule (IPI.ExposedModule mod_name (Just mod))
= (mod_name, mod)
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.PreExistingComponent (
PreExistingComponent(..),
ipiToPreExistingComponent,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Backpack.ModuleShape
import Distribution.Backpack
import Distribution.Types.ComponentId
import Distribution.Types.MungedPackageId
import Distribution.Types.PackageId
import Distribution.Types.UnitId
import Distribution.Types.ComponentName
import Distribution.Types.PackageName
import Distribution.Package
import qualified Data.Map as Map
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-- | Stripped down version of 'LinkedComponent' for things
-- we don't need to know how to build.
data PreExistingComponent
= PreExistingComponent {
-- | The actual name of the package. This may DISAGREE with 'pc_pkgid'
-- for internal dependencies: e.g., an internal component @lib@ may be
-- munged to @z-pkg-z-lib@, but we still want to use it when we see
-- @lib@ in @build-depends@
pc_pkgname :: PackageName,
-- | The actual name of the component.
pc_compname :: ComponentName,
pc_munged_id :: MungedPackageId,
pc_uid :: UnitId,
pc_cid :: ComponentId,
pc_open_uid :: OpenUnitId,
pc_shape :: ModuleShape
}
-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent',
-- which was brought into scope under the 'PackageName' (important for
-- a package qualified reference.)
ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent
ipiToPreExistingComponent ipi =
PreExistingComponent {
pc_pkgname = packageName ipi,
pc_compname = CLibName $ Installed.sourceLibName ipi,
pc_munged_id = mungedId ipi,
pc_uid = Installed.installedUnitId ipi,
pc_cid = Installed.installedComponentId ipi,
pc_open_uid =
IndefFullUnitId (Installed.installedComponentId ipi)
(Map.fromList (Installed.instantiatedWith ipi)),
pc_shape = shapeInstalledPackage ipi
}
instance HasMungedPackageId PreExistingComponent where
mungedId = pc_munged_id
instance Package PreExistingComponent where
packageId pec = PackageIdentifier (pc_pkgname pec) v
where MungedPackageId _ v = pc_munged_id pec
instance HasUnitId PreExistingComponent where
installedUnitId = pc_uid
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Backpack.PreModuleShape (
PreModuleShape(..),
toPreModuleShape,
renamePreModuleShape,
mixLinkPreModuleShape,
) where
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.Set as Set
import qualified Data.Map as Map
import Distribution.Backpack.ModuleShape
import Distribution.Types.IncludeRenaming
import Distribution.Types.ModuleRenaming
import Distribution.ModuleName
data PreModuleShape = PreModuleShape {
preModShapeProvides :: Set ModuleName,
preModShapeRequires :: Set ModuleName
}
deriving (Eq, Show, Generic)
toPreModuleShape :: ModuleShape -> PreModuleShape
toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs
renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape
renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) =
PreModuleShape
(Set.fromList (mapMaybe prov_fn (Set.toList provs)))
(Set.map req_fn reqs)
where
prov_fn = interpModuleRenaming prov_rn
req_fn k = fromMaybe k (interpModuleRenaming req_rn k)
mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape
mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs)
where
provs = Set.unions (map preModShapeProvides shapes)
reqs = Set.unions (map preModShapeRequires shapes)
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternGuards #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ReadyComponent (
ReadyComponent(..),
InstantiatedComponent(..),
IndefiniteComponent(..),
rc_depends,
rc_uid,
rc_pkgid,
dispReadyComponent,
toReadyComponents,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
import Distribution.Backpack
import Distribution.Backpack.LinkedComponent
import Distribution.Backpack.ModuleShape
import Distribution.Types.AnnotatedId
import Distribution.Types.ModuleRenaming
import Distribution.Types.Component
import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentId
import Distribution.Types.ComponentName
import Distribution.Types.PackageId
import Distribution.Types.PackageName.Magic
import Distribution.Types.UnitId
import Distribution.Compat.Graph (IsNode(..))
import Distribution.Types.Module
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
import Distribution.Types.Library
import Distribution.Types.LibraryName
import Distribution.ModuleName
import Distribution.Package
import Distribution.Simple.Utils
import qualified Control.Applicative as A
import qualified Data.Traversable as T
import Control.Monad
import Text.PrettyPrint
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Version
import Distribution.Pretty
-- | A 'ReadyComponent' is one that we can actually generate build
-- products for. We have a ready component for the typecheck-only
-- products of every indefinite package, as well as a ready component
-- for every way these packages can be fully instantiated.
--
data ReadyComponent
= ReadyComponent {
rc_ann_id :: AnnotatedId UnitId,
-- | The 'OpenUnitId' for this package. At the moment, this
-- is used in only one case, which is to determine if an
-- export is of a module from this library (indefinite
-- libraries record these exports as 'OpenModule');
-- 'rc_open_uid' can be conveniently used to test for
-- equality, whereas 'UnitId' cannot always be used in this
-- case.
rc_open_uid :: OpenUnitId,
-- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid'
-- records a 'ComponentId', it coincides with this one.
rc_cid :: ComponentId,
-- | Corresponds to 'lc_component'.
rc_component :: Component,
-- | Corresponds to 'lc_exe_deps'.
-- Build-tools don't participate in mix-in linking.
-- (but what if they could?)
rc_exe_deps :: [AnnotatedId UnitId],
-- | Corresponds to 'lc_public'.
rc_public :: Bool,
-- | Extra metadata depending on whether or not this is an
-- indefinite library (typechecked only) or an instantiated
-- component (can be compiled).
rc_i :: Either IndefiniteComponent InstantiatedComponent
}
-- | The final, string 'UnitId' that will uniquely identify
-- the compilation products of this component.
rc_uid :: ReadyComponent -> UnitId
rc_uid = ann_id . rc_ann_id
-- | Corresponds to 'lc_pkgid'.
rc_pkgid :: ReadyComponent -> PackageId
rc_pkgid = ann_pid . rc_ann_id
-- | An 'InstantiatedComponent' is a library which is fully instantiated
-- (or, possibly, has no requirements at all.)
data InstantiatedComponent
= InstantiatedComponent {
-- | How this library was instantiated.
instc_insts :: [(ModuleName, Module)],
-- | Dependencies induced by 'instc_insts'. These are recorded
-- here because there isn't a convenient way otherwise to get
-- the 'PackageId' we need to fill 'componentPackageDeps' as needed.
instc_insts_deps :: [(UnitId, MungedPackageId)],
-- | The modules exported/reexported by this library.
instc_provides :: Map ModuleName Module,
-- | The dependencies which need to be passed to the compiler
-- to bring modules into scope. These always refer to installed
-- fully instantiated libraries.
instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
}
-- | An 'IndefiniteComponent' is a library with requirements
-- which we will typecheck only.
data IndefiniteComponent
= IndefiniteComponent {
-- | The requirements of the library.
indefc_requires :: [ModuleName],
-- | The modules exported/reexported by this library.
indefc_provides :: Map ModuleName OpenModule,
-- | The dependencies which need to be passed to the compiler
-- to bring modules into scope. These are 'OpenUnitId' because
-- these may refer to partially instantiated libraries.
indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
}
-- | Compute the dependencies of a 'ReadyComponent' that should
-- be recorded in the @depends@ field of 'InstalledPackageInfo'.
rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends rc = ordNub $
case rc_i rc of
Left indefc ->
map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))
(indefc_includes indefc)
Right instc ->
map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))
(instc_includes instc)
++ instc_insts_deps instc
where
toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId
toMungedPackageId ci =
computeCompatPackageId
(ci_pkgid ci)
(case ci_cname ci of
CLibName name -> name
_ -> error $ prettyShow (rc_cid rc) ++
" depends on non-library " ++ prettyShow (ci_id ci))
-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is
-- a library.
rc_munged_id :: ReadyComponent -> MungedPackageId
rc_munged_id rc =
computeCompatPackageId
(rc_pkgid rc)
(case rc_component rc of
CLib lib -> libName lib
_ -> error "rc_munged_id: not library")
instance Package ReadyComponent where
packageId = rc_pkgid
instance HasUnitId ReadyComponent where
installedUnitId = rc_uid
instance IsNode ReadyComponent where
type Key ReadyComponent = UnitId
nodeKey = rc_uid
nodeNeighbors rc =
(case rc_i rc of
Right inst | [] <- instc_insts inst
-> []
| otherwise
-> [newSimpleUnitId (rc_cid rc)]
_ -> []) ++
ordNub (map fst (rc_depends rc)) ++
map ann_id (rc_exe_deps rc)
dispReadyComponent :: ReadyComponent -> Doc
dispReadyComponent rc =
hang (text (case rc_i rc of
Left _ -> "indefinite"
Right _ -> "definite")
<+> pretty (nodeKey rc)
{- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $
vcat [ text "depends" <+> pretty uid
| uid <- nodeNeighbors rc ]
-- | The state of 'InstM'; a mapping from 'UnitId's to their
-- ready component, or @Nothing@ if its an external
-- component which we don't know how to build.
type InstS = Map UnitId (Maybe ReadyComponent)
-- | A state monad for doing instantiations (can't use actual
-- State because that would be an extra dependency.)
newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }
instance Functor InstM where
fmap f (InstM m) = InstM $ \s -> let (x, s') = m s
in (f x, s')
instance A.Applicative InstM where
pure a = InstM $ \s -> (a, s)
InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s
(x', s'') = x s'
in (f' x', s'')
instance Monad InstM where
return = A.pure
InstM m >>= f = InstM $ \s -> let (x, s') = m s
in runInstM (f x) s'
-- | Given a list of 'LinkedComponent's, expand the module graph
-- so that we have an instantiated graph containing all of the
-- instantiated components we need to build.
--
-- Instantiation intuitively follows the following algorithm:
--
-- instantiate a definite unit id p[S]:
-- recursively instantiate each module M in S
-- recursively instantiate modules exported by this unit
-- recursively instantiate dependencies substituted by S
--
-- The implementation is a bit more involved to memoize instantiation
-- if we have done it already.
--
-- We also call 'improveUnitId' during this process, so that fully
-- instantiated components are given 'HashedUnitId'.
--
toReadyComponents
:: Map UnitId MungedPackageId
-> Map ModuleName Module -- subst for the public component
-> [LinkedComponent]
-> [ReadyComponent]
toReadyComponents pid_map subst0 comps
= catMaybes (Map.elems ready_map)
where
cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]
instantiateUnitId :: ComponentId -> Map ModuleName Module
-> InstM DefUnitId
instantiateUnitId cid insts = InstM $ \s ->
case Map.lookup uid s of
Nothing ->
-- Knot tied
let (r, s') = runInstM (instantiateComponent uid cid insts)
(Map.insert uid r s)
in (def_uid, Map.insert uid r s')
Just _ -> (def_uid, s)
where
-- The mkDefUnitId here indicates that we assume
-- that Cabal handles unit id hash allocation.
-- Good thing about hashing here: map is only on string.
-- Bad thing: have to repeatedly hash.
def_uid = mkDefUnitId cid insts
uid = unDefUnitId def_uid
instantiateComponent
:: UnitId -> ComponentId -> Map ModuleName Module
-> InstM (Maybe ReadyComponent)
instantiateComponent uid cid insts
| Just lc <- Map.lookup cid cmap = do
provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc))
-- NB: lc_sig_includes is omitted here, because we don't
-- need them to build
includes <- forM (lc_includes lc) $ \ci -> do
uid' <- substUnitId insts (ci_id ci)
return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) }
exe_deps <- mapM (substExeDep insts) (lc_exe_deps lc)
s <- InstM $ \s -> (s, s)
let getDep (Module dep_def_uid _)
| let dep_uid = unDefUnitId dep_def_uid
-- Lose DefUnitId invariant for rc_depends
= [(dep_uid,
fromMaybe err_pid $
Map.lookup dep_uid pid_map A.<|>
fmap rc_munged_id (join (Map.lookup dep_uid s)))]
where
err_pid = MungedPackageId
(MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)
(mkVersion [0])
instc = InstantiatedComponent {
instc_insts = Map.toList insts,
instc_insts_deps = concatMap getDep (Map.elems insts),
instc_provides = provides,
instc_includes = includes
-- NB: there is no dependency on the
-- indefinite version of this instantiated package here,
-- as (1) it doesn't go in depends in the
-- IPI: it's not a run time dep, and (2)
-- we don't have to tell GHC about it, it
-- will match up the ComponentId
-- automatically
}
return $ Just ReadyComponent {
rc_ann_id = (lc_ann_id lc) { ann_id = uid },
rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid),
rc_cid = lc_cid lc,
rc_component = lc_component lc,
rc_exe_deps = exe_deps,
rc_public = lc_public lc,
rc_i = Right instc
}
| otherwise = return Nothing
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId _ (DefiniteUnitId uid) =
return uid
substUnitId subst (IndefFullUnitId cid insts) = do
insts' <- substSubst subst insts
instantiateUnitId cid insts'
-- NB: NOT composition
substSubst :: Map ModuleName Module
-> Map ModuleName OpenModule
-> InstM (Map ModuleName Module)
substSubst subst insts = T.mapM (substModule subst) insts
substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule subst (OpenModuleVar mod_name)
| Just m <- Map.lookup mod_name subst = return m
| otherwise = error "substModule: non-closing substitution"
substModule subst (OpenModule uid mod_name) = do
uid' <- substUnitId subst uid
return (Module uid' mod_name)
substExeDep :: Map ModuleName Module
-> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
substExeDep insts exe_aid = do
exe_uid' <- substUnitId insts (ann_id exe_aid)
return exe_aid { ann_id = unDefUnitId exe_uid' }
indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId cid = do
let uid = newSimpleUnitId cid
r <- indefiniteComponent uid cid
InstM $ \s -> (uid, Map.insert uid r s)
indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent uid cid
| Just lc <- Map.lookup cid cmap = do
-- We're going to process includes, in case some of them
-- are fully definite even without any substitution. We
-- want to build those too; see #5634.
inst_includes <- forM (lc_includes lc) $ \ci ->
if Set.null (openUnitIdFreeHoles (ci_id ci))
then do uid' <- substUnitId Map.empty (ci_id ci)
return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) }
else return ci
exe_deps <- mapM (substExeDep Map.empty) (lc_exe_deps lc)
let indefc = IndefiniteComponent {
indefc_requires = map fst (lc_insts lc),
indefc_provides = modShapeProvides (lc_shape lc),
indefc_includes = inst_includes ++ lc_sig_includes lc
}
return $ Just ReadyComponent {
rc_ann_id = (lc_ann_id lc) { ann_id = uid },
rc_cid = lc_cid lc,
rc_open_uid = lc_uid lc,
rc_component = lc_component lc,
-- It's always fully built
rc_exe_deps = exe_deps,
rc_public = lc_public lc,
rc_i = Left indefc
}
| otherwise = return Nothing
ready_map = snd $ runInstM work Map.empty
work
-- Top-level instantiation per subst0
| not (Map.null subst0)
, [lc] <- filter lc_public (Map.elems cmap)
= do _ <- instantiateUnitId (lc_cid lc) subst0
return ()
| otherwise
= forM_ (Map.elems cmap) $ \lc ->
if null (lc_insts lc)
then instantiateUnitId (lc_cid lc) Map.empty >> return ()
else indefiniteUnitId (lc_cid lc) >> return ()
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.UnifyM (
-- * Unification monad
UnifyM,
runUnifyM,
failWith,
addErr,
failIfErrs,
tryM,
addErrContext,
addErrContextM,
liftST,
UnifEnv(..),
getUnifEnv,
-- * Modules and unit IDs
ModuleU,
ModuleU'(..),
convertModule,
convertModuleU,
UnitIdU,
UnitIdU'(..),
convertUnitId,
convertUnitIdU,
ModuleSubstU,
convertModuleSubstU,
convertModuleSubst,
ModuleScopeU,
emptyModuleScopeU,
convertModuleScopeU,
ModuleWithSourceU,
convertInclude,
convertModuleProvides,
convertModuleProvidesU,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Backpack.ModuleShape
import Distribution.Backpack.ModuleScope
import Distribution.Backpack.ModSubst
import Distribution.Backpack.FullUnitId
import Distribution.Backpack
import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Types.IncludeRenaming
import Distribution.Types.ComponentInclude
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentName
import Distribution.Verbosity
import Data.STRef
import Data.Traversable
import Control.Monad.ST
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.Traversable as T
import Text.PrettyPrint
-- TODO: more detailed trace output on high verbosity would probably
-- be appreciated by users debugging unification errors. Collect
-- some good examples!
data ErrMsg = ErrMsg {
err_msg :: Doc,
err_ctx :: [Doc]
}
type MsgDoc = Doc
renderErrMsg :: ErrMsg -> MsgDoc
renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } =
msg $$ vcat ctx
-- | The unification monad, this monad encapsulates imperative
-- unification.
newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) }
-- | Run a computation in the unification monad.
runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a
runUnifyM verbosity self_cid db m
= runST $ do i <- newSTRef 0
hmap <- newSTRef Map.empty
errs <- newSTRef []
mb_r <- unUnifyM m UnifEnv {
unify_uniq = i,
unify_reqs = hmap,
unify_self_cid = self_cid,
unify_verbosity = verbosity,
unify_ctx = [],
unify_db = db,
unify_errs = errs }
final_errs <- readSTRef errs
case mb_r of
Just x | null final_errs -> return (Right x)
_ -> return (Left (map renderErrMsg (reverse final_errs)))
-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.
type ErrCtx s = MsgDoc
-- | The unification environment.
data UnifEnv s = UnifEnv {
-- | A supply of unique integers to label 'UnitIdU'
-- cells. This is used to determine loops in unit
-- identifiers (which can happen with mutual recursion.)
unify_uniq :: UnifRef s UnitIdUnique,
-- | The set of requirements in scope. When
-- a provision is brought into scope, we unify with
-- the requirement at the same module name to fill it.
-- This mapping grows monotonically.
unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),
-- | Component id of the unit we're linking. We use this
-- to detect if we fill a requirement with a local module,
-- which in principle should be OK but is not currently
-- supported by GHC.
unify_self_cid :: ComponentId,
-- | How verbose the error message should be
unify_verbosity :: Verbosity,
-- | The error reporting context
unify_ctx :: [ErrCtx s],
-- | The package index for expanding unit identifiers
unify_db :: FullDb,
-- | Accumulated errors
unify_errs :: UnifRef s [ErrMsg]
}
instance Functor (UnifyM s) where
fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)
instance Applicative (UnifyM s) where
pure = UnifyM . pure . pure . pure
UnifyM f <*> UnifyM x = UnifyM $ \r -> do
f' <- f r
case f' of
Nothing -> return Nothing
Just f'' -> do
x' <- x r
case x' of
Nothing -> return Nothing
Just x'' -> return (Just (f'' x''))
instance Monad (UnifyM s) where
return = pure
UnifyM m >>= f = UnifyM $ \r -> do
x <- m r
case x of
Nothing -> return Nothing
Just x' -> unUnifyM (f x') r
-- | Lift a computation from 'ST' monad to 'UnifyM' monad.
-- Internal use only.
liftST :: ST s a -> UnifyM s a
liftST m = UnifyM $ \_ -> fmap Just m
addErr :: MsgDoc -> UnifyM s ()
addErr msg = do
env <- getUnifEnv
let err = ErrMsg {
err_msg = msg,
err_ctx = unify_ctx env
}
liftST $ modifySTRef (unify_errs env) (\errs -> err:errs)
failWith :: MsgDoc -> UnifyM s a
failWith msg = do
addErr msg
failM
failM :: UnifyM s a
failM = UnifyM $ \_ -> return Nothing
failIfErrs :: UnifyM s ()
failIfErrs = do
env <- getUnifEnv
errs <- liftST $ readSTRef (unify_errs env)
when (not (null errs)) failM
tryM :: UnifyM s a -> UnifyM s (Maybe a)
tryM m =
UnifyM (\env -> do
mb_r <- unUnifyM m env
return (Just mb_r))
{-
otherFail :: ErrMsg -> UnifyM s a
otherFail s = UnifyM $ \_ -> return (Left s)
unifyFail :: ErrMsg -> UnifyM s a
unifyFail err = do
env <- getUnifEnv
msg <- case unify_ctx env of
Nothing -> return (text "Unspecified unification error:" <+> err)
Just (ctx, mod1, mod2)
| unify_verbosity env > normal
-> do mod1' <- convertModuleU mod1
mod2' <- convertModuleU mod2
let extra = " (was unifying " ++ display mod1'
++ " and " ++ display mod2' ++ ")"
return (ctx ++ err ++ extra)
| otherwise
-> return (ctx ++ err ++ " (for more information, pass -v flag)")
UnifyM $ \_ -> return (Left msg)
-}
-- | A convenient alias for mutable references in the unification monad.
type UnifRef s a = STRef s a
-- | Imperatively read a 'UnifRef'.
readUnifRef :: UnifRef s a -> UnifyM s a
readUnifRef = liftST . readSTRef
-- | Imperatively write a 'UnifRef'.
writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
writeUnifRef x = liftST . writeSTRef x
-- | Get the current unification environment.
getUnifEnv :: UnifyM s (UnifEnv s)
getUnifEnv = UnifyM $ \r -> return (return r)
-- | Add a fixed message to the error context.
addErrContext :: Doc -> UnifyM s a -> UnifyM s a
addErrContext ctx m = addErrContextM ctx m
-- | Add a message to the error context. It may make monadic queries.
addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
addErrContextM ctx m =
UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r }
-----------------------------------------------------------------------
-- The "unifiable" variants of the data types
--
-- In order to properly do unification over infinite trees, we
-- need to union find over 'Module's and 'UnitId's. The pure
-- representation is ill-equipped to do this, so we convert
-- from the pure representation into one which is indirected
-- through union-find. 'ModuleU' handles hole variables;
-- 'UnitIdU' handles mu-binders.
-- | Contents of a mutable 'ModuleU' reference.
data ModuleU' s
= ModuleU (UnitIdU s) ModuleName
| ModuleVarU ModuleName
-- | Contents of a mutable 'UnitIdU' reference.
data UnitIdU' s
= UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
| UnitIdThunkU DefUnitId
-- | A mutable version of 'Module' which can be imperatively unified.
type ModuleU s = UnionFind.Point s (ModuleU' s)
-- | A mutable version of 'UnitId' which can be imperatively unified.
type UnitIdU s = UnionFind.Point s (UnitIdU' s)
-- | An integer for uniquely labeling 'UnitIdU' nodes. We need
-- these labels in order to efficiently serialize 'UnitIdU's into
-- 'UnitId's (we use the label to check if any parent is the
-- node in question, and if so insert a deBruijn index instead.)
-- These labels must be unique across all 'UnitId's/'Module's which
-- participate in unification!
type UnitIdUnique = Int
-----------------------------------------------------------------------
-- Conversion to the unifiable data types
-- An environment for tracking the mu-bindings in scope.
-- The invariant for a state @(m, i)@ is that [0..i] are
-- keys of @m@; in fact, the @i-k@th entry is the @k@th
-- de Bruijn index (this saves us from having to shift as
-- we enter mu-binders.)
type MuEnv s = (IntMap (UnitIdU s), Int)
extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s
extendMuEnv (m, i) x =
(IntMap.insert (i + 1) x m, i + 1)
{-
lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s
lookupMuEnv (m, i) k =
case IntMap.lookup (i - k) m of
-- Technically a user can trigger this by giving us a
-- bad 'UnitId', so handle this better.
Nothing -> error "lookupMuEnv: out of bounds (malformed de Bruijn index)"
Just v -> v
-}
emptyMuEnv :: MuEnv s
emptyMuEnv = (IntMap.empty, -1)
-- The workhorse functions. These share an environment:
-- * @UnifRef s UnitIdUnique@ - the unique label supply for 'UnitIdU' nodes
-- * @UnifRef s (Map ModuleName moduleU)@ - the (lazily initialized)
-- environment containing the implicitly universally quantified
-- @hole:A@ binders.
-- * @MuEnv@ - the environment for mu-binders.
convertUnitId' :: MuEnv s
-> OpenUnitId
-> UnifyM s (UnitIdU s)
-- TODO: this could be more lazy if we know there are no internal
-- references
convertUnitId' _ (DefiniteUnitId uid) =
liftST $ UnionFind.fresh (UnitIdThunkU uid)
convertUnitId' stk (IndefFullUnitId cid insts) = do
fs <- fmap unify_uniq getUnifEnv
x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later
insts_u <- T.forM insts $ convertModule' (extendMuEnv stk x)
u <- readUnifRef fs
writeUnifRef fs (u+1)
y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)
liftST $ UnionFind.union x y
return y
-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)
convertModule' :: MuEnv s
-> OpenModule -> UnifyM s (ModuleU s)
convertModule' _stk (OpenModuleVar mod_name) = do
hmap <- fmap unify_reqs getUnifEnv
hm <- readUnifRef hmap
case Map.lookup mod_name hm of
Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)
writeUnifRef hmap (Map.insert mod_name mod hm)
return mod
Just mod -> return mod
convertModule' stk (OpenModule uid mod_name) = do
uid_u <- convertUnitId' stk uid
liftST $ UnionFind.fresh (ModuleU uid_u mod_name)
convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId = convertUnitId' emptyMuEnv
convertModule :: OpenModule -> UnifyM s (ModuleU s)
convertModule = convertModule' emptyMuEnv
-----------------------------------------------------------------------
-- Substitutions
-- | The mutable counterpart of a 'ModuleSubst' (not defined here).
type ModuleSubstU s = Map ModuleName (ModuleU s)
-- | Conversion of 'ModuleSubst' to 'ModuleSubstU'
convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst = T.mapM convertModule
-- | Conversion of 'ModuleSubstU' to 'ModuleSubst'
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU = T.mapM convertModuleU
-----------------------------------------------------------------------
-- Conversion from the unifiable data types
-- An environment for tracking candidates for adding a mu-binding.
-- The invariant for a state @(m, i)@, is that if we encounter a node
-- labeled @k@ such that @m[k -> v]@, then we can replace this
-- node with the de Bruijn index @i-v@ referring to an enclosing
-- mu-binder; furthermore, @range(m) = [0..i]@.
type MooEnv = (IntMap Int, Int)
emptyMooEnv :: MooEnv
emptyMooEnv = (IntMap.empty, -1)
extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv
extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1)
lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int
lookupMooEnv (m, i) k =
case IntMap.lookup k m of
Nothing -> Nothing
Just v -> Just (i-v) -- de Bruijn indexize
-- The workhorse functions
convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU' stk uid_u = do
x <- liftST $ UnionFind.find uid_u
case x of
UnitIdThunkU uid -> return (DefiniteUnitId uid)
UnitIdU u cid insts_u ->
case lookupMooEnv stk u of
Just _i ->
failWith (text "Unsupported mutually recursive unit identifier")
-- return (UnitIdVar i)
Nothing -> do
insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u)
return (IndefFullUnitId cid insts)
convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' stk mod_u = do
mod <- liftST $ UnionFind.find mod_u
case mod of
ModuleVarU mod_name -> return (OpenModuleVar mod_name)
ModuleU uid_u mod_name -> do
uid <- convertUnitIdU' stk uid_u
return (OpenModule uid mod_name)
-- Helper functions
convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU = convertUnitIdU' emptyMooEnv
convertModuleU :: ModuleU s -> UnifyM s OpenModule
convertModuleU = convertModuleU' emptyMooEnv
-- | An empty 'ModuleScopeU'.
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU = (Map.empty, Map.empty)
-- | The mutable counterpart of 'ModuleScope'.
type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)
-- | The mutable counterpart of 'ModuleProvides'
type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]
type ModuleRequiresU s = ModuleProvidesU s
type ModuleWithSourceU s = WithSource (ModuleU s)
-- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource
ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
ci_msg ci
| ci_implicit ci = text "build-depends:" <+> pp_pn
| otherwise = text "mixins:" <+> pp_pn <+> pretty (ci_renaming ci)
where
pn = pkgName (ci_pkgid ci)
pp_pn =
case ci_cname ci of
CLibName LMainLibName -> pretty pn
CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn
-- Shouldn't happen
cn -> pretty pn <+> parens (pretty cn)
-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do
-- unification on it.
convertInclude
:: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM s (ModuleScopeU s,
Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -}
(ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -})
convertInclude ci@(ComponentInclude {
ci_ann_id = AnnotatedId {
ann_id = (uid, ModuleShape provs reqs),
ann_pid = pid,
ann_cname = compname
},
ci_renaming = incl@(IncludeRenaming prov_rns req_rns),
ci_implicit = implicit
}) = addErrContext (text "In" <+> ci_msg ci) $ do
let pn = packageName pid
the_source | implicit
= FromBuildDepends pn compname
| otherwise
= FromMixins pn compname incl
source = WithSource the_source
-- Suppose our package has two requirements A and B, and
-- we include it with @requires (A as X)@
-- There are three closely related things we compute based
-- off of @reqs@ and @reqs_rns@:
--
-- 1. The requirement renaming (A -> X)
-- 2. The requirement substitution (A -> <X>, B -> <B>)
-- Requirement renaming. This is read straight off the syntax:
--
-- [nothing] ==> [empty]
-- requires (B as Y) ==> B -> Y
--
-- Requirement renamings are NOT injective: if two requirements
-- are mapped to the same name, the intent is to merge them
-- together. But they are *functions*, so @B as X, B as Y@ is
-- illegal.
req_rename_list <-
case req_rns of
DefaultRenaming -> return []
HidingRenaming _ -> do
-- Not valid here for requires!
addErr $ text "Unsupported syntax" <+>
quotes (text "requires hiding (...)")
return []
ModuleRenaming rns -> return rns
let req_rename_listmap :: Map ModuleName [ModuleName]
req_rename_listmap =
Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ]
req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->
case vs0 of
[] -> error "req_rename"
[v] -> return v
v:vs -> do addErr $
text "Conflicting renamings of requirement" <+> quotes (pretty k) $$
text "Renamed to: " <+> vcat (map pretty (v:vs))
return v
let req_rename_fn k = case Map.lookup k req_rename of
Nothing -> k
Just v -> v
-- Requirement substitution.
--
-- A -> X ==> A -> <X>
let req_subst = fmap OpenModuleVar req_rename
uid_u <- convertUnitId (modSubst req_subst uid)
-- Requirement mapping. This is just taking the range of the
-- requirement substitution, and making a mapping so that it is
-- convenient to merge things together. It INCLUDES the implicit
-- mappings.
--
-- A -> X ==> X -> <X>, B -> <B>
reqs_u <- convertModuleRequires . Map.fromList $
[ (k, [source (OpenModuleVar k)])
| k <- map req_rename_fn (Set.toList reqs)
]
-- Report errors if there were unused renamings
let leftover = Map.keysSet req_rename `Set.difference` reqs
unless (Set.null leftover) $
addErr $
hang (text "The" <+> text (showComponentName compname) <+>
text "from package" <+> quotes (pretty pid)
<+> text "does not require:") 4
(vcat (map pretty (Set.toList leftover)))
-- Provision computation is more complex.
-- For example, if we have:
--
-- include p (A as X) requires (B as Y)
-- where A -> q[B=<B>]:A
--
-- Then we need:
--
-- X -> [("p", q[B=<B>]:A)]
--
-- There are a bunch of clever ways to present the algorithm
-- but here is the simple one:
--
-- 1. If we have a default renaming, apply req_subst
-- to provs and use that.
--
-- 2. Otherwise, build a map by successively looking
-- up the referenced modules in the renaming in provs.
--
-- Importantly, overlapping rename targets get accumulated
-- together. It's not an (immediate) error.
(pre_prov_scope, prov_rns') <-
case prov_rns of
DefaultRenaming -> return (Map.toList provs, prov_rns)
HidingRenaming hides ->
let hides_set = Set.fromList hides
in let r = [ (k,v)
| (k,v) <- Map.toList provs
, not (k `Set.member` hides_set) ]
-- GHC doesn't understand hiding, so expand it out!
in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r))
ModuleRenaming rns -> do
r <- sequence
[ case Map.lookup from provs of
Just m -> return (to, m)
Nothing -> failWith $
text "Package" <+> quotes (pretty pid) <+>
text "does not expose the module" <+> quotes (pretty from)
| (from, to) <- rns ]
return (r, prov_rns)
let prov_scope = modSubst req_subst
$ Map.fromListWith (++)
[ (k, [source v])
| (k, v) <- pre_prov_scope ]
provs_u <- convertModuleProvides prov_scope
-- TODO: Assert that provs_u is empty if provs was empty
return ((provs_u, reqs_u),
-- NB: We test that requirements is not null so that
-- users can create packages with zero module exports
-- that cause some C library to linked in, etc.
(if Map.null provs && not (Set.null reqs)
then Right -- is sig
else Left) (ComponentInclude {
ci_ann_id = AnnotatedId {
ann_id = uid_u,
ann_pid = pid,
ann_cname = compname
},
ci_renaming = prov_rns',
ci_implicit = ci_implicit ci
}))
-- | Convert a 'ModuleScopeU' to a 'ModuleScope'.
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU (provs_u, reqs_u) = do
provs <- convertModuleProvidesU provs_u
reqs <- convertModuleRequiresU reqs_u
-- TODO: Test that the requirements are still free. If they
-- are not, they got unified, and that's dodgy at best.
return (ModuleScope provs reqs)
-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
convertModuleProvides = T.mapM (mapM (T.mapM convertModule))
-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'
convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides
convertModuleProvidesU = T.mapM (mapM (T.mapM convertModuleU))
convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires = convertModuleProvides
convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires
convertModuleRequiresU = convertModuleProvidesU
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.CabalSpecVersion where
import Prelude ()
import Distribution.Compat.Prelude
-- | Different Cabal-the-spec versions.
--
-- We branch based on this at least in the parser.
--
data CabalSpecVersion
= CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2'
| CabalSpecV1_2 -- ^ new syntax (sections)
| CabalSpecV1_4
| CabalSpecV1_6
| CabalSpecV1_8
| CabalSpecV1_10
| CabalSpecV1_12
-- 1.16 -- 1.14: no changes
| CabalSpecV1_18
| CabalSpecV1_20
| CabalSpecV1_22
| CabalSpecV1_24
| CabalSpecV2_0
| CabalSpecV2_2
| CabalSpecV2_4
| CabalSpecV3_0
-- 3.2: no changes
| CabalSpecV3_4
deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic)
instance Binary CabalSpecVersion
instance Structured CabalSpecVersion
instance NFData CabalSpecVersion where rnf = genericRnf
-- | Show cabal spec version, but not the way in the .cabal files
--
-- @since 3.0.0.0
showCabalSpecVersion :: CabalSpecVersion -> String
showCabalSpecVersion CabalSpecV3_4 = "3.4"
showCabalSpecVersion CabalSpecV3_0 = "3.0"
showCabalSpecVersion CabalSpecV2_4 = "2.4"
showCabalSpecVersion CabalSpecV2_2 = "2.2"
showCabalSpecVersion CabalSpecV2_0 = "2.0"
showCabalSpecVersion CabalSpecV1_24 = "1.24"
showCabalSpecVersion CabalSpecV1_22 = "1.22"
showCabalSpecVersion CabalSpecV1_20 = "1.20"
showCabalSpecVersion CabalSpecV1_18 = "1.18"
showCabalSpecVersion CabalSpecV1_12 = "1.12"
showCabalSpecVersion CabalSpecV1_10 = "1.10"
showCabalSpecVersion CabalSpecV1_8 = "1.8"
showCabalSpecVersion CabalSpecV1_6 = "1.6"
showCabalSpecVersion CabalSpecV1_4 = "1.4"
showCabalSpecVersion CabalSpecV1_2 = "1.2"
showCabalSpecVersion CabalSpecV1_0 = "1.0"
cabalSpecLatest :: CabalSpecVersion
cabalSpecLatest = CabalSpecV3_4
-- | Parse 'CabalSpecVersion' from version digits.
--
-- It may fail if for recent versions the version is not exact.
--
cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion
cabalSpecFromVersionDigits v
| v == [3,4] = Just CabalSpecV3_4
| v == [3,0] = Just CabalSpecV3_0
| v == [2,4] = Just CabalSpecV2_4
| v == [2,2] = Just CabalSpecV2_2
| v == [2,0] = Just CabalSpecV2_0
| v >= [1,25] = Nothing
| v >= [1,23] = Just CabalSpecV1_24
| v >= [1,21] = Just CabalSpecV1_22
| v >= [1,19] = Just CabalSpecV1_20
| v >= [1,17] = Just CabalSpecV1_18
| v >= [1,11] = Just CabalSpecV1_12
| v >= [1,9] = Just CabalSpecV1_10
| v >= [1,7] = Just CabalSpecV1_8
| v >= [1,5] = Just CabalSpecV1_6
| v >= [1,3] = Just CabalSpecV1_4
| v >= [1,1] = Just CabalSpecV1_2
| otherwise = Just CabalSpecV1_0
-- | @since 3.4.0.0
cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecV3_4 = [3,4]
cabalSpecToVersionDigits CabalSpecV3_0 = [3,0]
cabalSpecToVersionDigits CabalSpecV2_4 = [2,4]
cabalSpecToVersionDigits CabalSpecV2_2 = [2,2]
cabalSpecToVersionDigits CabalSpecV2_0 = [2,0]
cabalSpecToVersionDigits CabalSpecV1_24 = [1,24]
cabalSpecToVersionDigits CabalSpecV1_22 = [1,22]
cabalSpecToVersionDigits CabalSpecV1_20 = [1,20]
cabalSpecToVersionDigits CabalSpecV1_18 = [1,18]
cabalSpecToVersionDigits CabalSpecV1_12 = [1,12]
cabalSpecToVersionDigits CabalSpecV1_10 = [1,10]
cabalSpecToVersionDigits CabalSpecV1_8 = [1,8]
cabalSpecToVersionDigits CabalSpecV1_6 = [1,6]
cabalSpecToVersionDigits CabalSpecV1_4 = [1,4]
cabalSpecToVersionDigits CabalSpecV1_2 = [1,2]
cabalSpecToVersionDigits CabalSpecV1_0 = [1,0]
-- | What is the minimum Cabal library version which knows how handle
-- this spec version.
--
-- /Note:/ this is a point where we could decouple cabal-spec and Cabal
-- versions, if we ever want that.
--
-- >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0
-- [2,5]
--
-- >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4
-- [2,3]
--
-- @since 3.4.0.0
cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int]
cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0]
cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of
[x,y] -> [x, y+1]
xs -> xs
specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas
specHasCommonStanzas v =
if v >= CabalSpecV2_2
then HasCommonStanzas
else NoCommonStanzas
specHasElif :: CabalSpecVersion -> HasElif
specHasElif v =
if v >= CabalSpecV2_2
then HasElif
else NoElif
-------------------------------------------------------------------------------
-- Booleans
-------------------------------------------------------------------------------
-- IDEA: make some kind of tagged booleans?
data HasElif = HasElif | NoElif
deriving (Eq, Show)
data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas
deriving (Eq, Show)
data HasGlobstar = HasGlobstar | NoGlobstar
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | 'Async', yet using 'MVar's.
--
-- Adopted from @async@ library
-- Copyright (c) 2012, Simon Marlow
-- Licensed under BSD-3-Clause
--
-- @since 3.2.0.0
--
module Distribution.Compat.Async (
AsyncM,
withAsync, waitCatch,
wait, asyncThreadId,
cancel, uninterruptibleCancel, AsyncCancelled (..),
-- * Cabal extras
withAsyncNF,
) where
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
import Control.DeepSeq (NFData, force)
import Control.Exception
(BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)
import Control.Monad (void)
import Data.Typeable (Typeable)
import GHC.Exts (inline)
#if MIN_VERSION_base(4,7,0)
import Control.Exception (asyncExceptionFromException, asyncExceptionToException)
#endif
-- | Async, but based on 'MVar', as we don't depend on @stm@.
data AsyncM a = Async
{ asyncThreadId :: {-# UNPACK #-} !ThreadId
-- ^ Returns the 'ThreadId' of the thread running
-- the given 'Async'.
, _asyncMVar :: MVar (Either SomeException a)
}
-- | Spawn an asynchronous action in a separate thread, and pass its
-- @Async@ handle to the supplied function. When the function returns
-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.
--
-- > withAsync action inner = mask $ \restore -> do
-- > a <- async (restore action)
-- > restore (inner a) `finally` uninterruptibleCancel a
--
-- This is a useful variant of 'async' that ensures an @Async@ is
-- never left running unintentionally.
--
-- Note: a reference to the child thread is kept alive until the call
-- to `withAsync` returns, so nesting many `withAsync` calls requires
-- linear memory.
--
withAsync :: IO a -> (AsyncM a -> IO b) -> IO b
withAsync = inline withAsyncUsing forkIO
withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b
withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where
evaluateNF = evaluate . force
withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
-- The bracket version works, but is slow. We can do better by
-- hand-coding it:
withAsyncUsing doFork = \action inner -> do
var <- newEmptyMVar
mask $ \restore -> do
t <- doFork $ try (restore action) >>= putMVar var
let a = Async t var
r <- restore (inner a) `catchAll` \e -> do
uninterruptibleCancel a
throwIO e
uninterruptibleCancel a
return r
-- | Wait for an asynchronous action to complete, and return its
-- value. If the asynchronous action threw an exception, then the
-- exception is re-thrown by 'wait'.
--
-- > wait = atomically . waitSTM
--
{-# INLINE wait #-}
wait :: AsyncM a -> IO a
wait a = do
res <- waitCatch a
case res of
Left (SomeException e) -> throwIO e
Right x -> return x
-- | Wait for an asynchronous action to complete, and return either
-- @Left e@ if the action raised an exception @e@, or @Right a@ if it
-- returned a value @a@.
--
-- > waitCatch = atomically . waitCatchSTM
--
{-# INLINE waitCatch #-}
waitCatch :: AsyncM a -> IO (Either SomeException a)
waitCatch (Async _ var) = tryAgain (readMVar var)
where
-- See: https://github.com/simonmar/async/issues/14
tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f
catchAll :: IO a -> (SomeException -> IO a) -> IO a
catchAll = catch
-- | Cancel an asynchronous action by throwing the @AsyncCancelled@
-- exception to it, and waiting for the `Async` thread to quit.
-- Has no effect if the 'Async' has already completed.
--
-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a
--
-- Note that 'cancel' will not terminate until the thread the 'Async'
-- refers to has terminated. This means that 'cancel' will block for
-- as long said thread blocks when receiving an asynchronous exception.
--
-- For example, it could block if:
--
-- * It's executing a foreign call, and thus cannot receive the asynchronous
-- exception;
-- * It's executing some cleanup handler after having received the exception,
-- and the handler is blocking.
{-# INLINE cancel #-}
cancel :: AsyncM a -> IO ()
cancel a@(Async t _) = do
throwTo t AsyncCancelled
void (waitCatch a)
-- | The exception thrown by `cancel` to terminate a thread.
data AsyncCancelled = AsyncCancelled
deriving (Show, Eq
, Typeable
)
instance Exception AsyncCancelled where
#if MIN_VERSION_base(4,7,0)
-- wraps in SomeAsyncException
-- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09
fromException = asyncExceptionFromException
toException = asyncExceptionToException
#endif
-- | Cancel an asynchronous action
--
-- This is a variant of `cancel`, but it is not interruptible.
{-# INLINE uninterruptibleCancel #-}
uninterruptibleCancel :: AsyncM a -> IO ()
uninterruptibleCancel = uninterruptibleMask_ . cancel
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 711
{-# LANGUAGE PatternSynonyms #-}
#endif
#ifndef MIN_VERSION_binary
#define MIN_VERSION_binary(x, y, z) 0
#endif
module Distribution.Compat.Binary
( decodeOrFailIO
, decodeFileOrFail'
#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)
, module Data.Binary
#else
, Binary(..)
, decode, encode, encodeFile
#endif
) where
import Control.Exception (ErrorCall (..), catch, evaluate)
import Data.ByteString.Lazy (ByteString)
#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)
import Data.Binary
-- | Lazily reconstruct a value previously written to a file.
decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)
decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f
#else
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BSL
import Distribution.Compat.Binary.Class
import Distribution.Compat.Binary.Generic ()
-- | Decode a value from a lazy ByteString, reconstructing the
-- original structure.
--
decode :: Binary a => ByteString -> a
decode = runGet get
-- | Encode a value using binary serialisation to a lazy ByteString.
--
encode :: Binary a => a -> ByteString
encode = runPut . put
{-# INLINE encode #-}
-- | Lazily reconstruct a value previously written to a file.
decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a)
decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f
-- | Lazily serialise a value to a file
encodeFile :: Binary a => FilePath -> a -> IO ()
encodeFile f = BSL.writeFile f . encode
#endif
decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)
decodeOrFailIO bs =
catch (evaluate (decode bs) >>= return . Right) handler
where
#if MIN_VERSION_base(4,9,0)
handler (ErrorCallWithLocation str _) = return $ Left str
#else
handler (ErrorCall str) = return $ Left str
#endif
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.Binary.Class
-- Copyright : Lennart Kolmodin
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com>
-- Stability : unstable
-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
--
-- Typeclass and instances for binary serialization.
--
-----------------------------------------------------------------------------
module Distribution.Compat.Binary.Class (
-- * The Binary class
Binary(..)
-- * Support for generics
, GBinary(..)
) where
import Data.Word
import Data.Binary.Put
import Data.Binary.Get
import Control.Applicative ((<$>), (<*>), (*>))
import Foreign
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Char (chr,ord)
import Data.List (unfoldr)
import Data.Foldable (traverse_)
-- And needed for the instances:
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Ratio as R
import qualified Data.Tree as T
import Data.Array.Unboxed
import GHC.Generics
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
------------------------------------------------------------------------
class GBinary f where
gput :: f t -> Put
gget :: Get (f t)
-- | The 'Binary' class provides 'put' and 'get', methods to encode and
-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
-- 'Show' classes for textual representation of Haskell types, and is
-- suitable for serialising Haskell values to disk, over the network.
--
-- For decoding and generating simple external binary formats (e.g. C
-- structures), Binary may be used, but in general is not suitable
-- for complex protocols. Instead use the 'Put' and 'Get' primitives
-- directly.
--
-- Instances of Binary should satisfy the following property:
--
-- > decode . encode == id
--
-- That is, the 'get' and 'put' methods should be the inverse of each
-- other. A range of instances are provided for basic Haskell types.
--
class Binary t where
-- | Encode a value in the Put monad.
put :: t -> Put
-- | Decode a value in the Get monad
get :: Get t
default put :: (Generic t, GBinary (Rep t)) => t -> Put
put = gput . from
default get :: (Generic t, GBinary (Rep t)) => Get t
get = to `fmap` gget
------------------------------------------------------------------------
-- Simple instances
-- The () type need never be written to disk: values of singleton type
-- can be reconstructed from the type alone
instance Binary () where
put () = return ()
get = return ()
-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
put = putWord8 . fromIntegral . fromEnum
get = fmap (toEnum . fromIntegral) getWord8
-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
put = putWord8 . fromIntegral . fromEnum
get = fmap (toEnum . fromIntegral) getWord8
------------------------------------------------------------------------
-- Words and Ints
-- Words8s are written as bytes
instance Binary Word8 where
put = putWord8
get = getWord8
-- Words16s are written as 2 bytes in big-endian (network) order
instance Binary Word16 where
put = putWord16be
get = getWord16be
-- Words32s are written as 4 bytes in big-endian (network) order
instance Binary Word32 where
put = putWord32be
get = getWord32be
-- Words64s are written as 8 bytes in big-endian (network) order
instance Binary Word64 where
put = putWord64be
get = getWord64be
-- Int8s are written as a single byte.
instance Binary Int8 where
put i = put (fromIntegral i :: Word8)
get = fmap fromIntegral (get :: Get Word8)
-- Int16s are written as a 2 bytes in big endian format
instance Binary Int16 where
put i = put (fromIntegral i :: Word16)
get = fmap fromIntegral (get :: Get Word16)
-- Int32s are written as a 4 bytes in big endian format
instance Binary Int32 where
put i = put (fromIntegral i :: Word32)
get = fmap fromIntegral (get :: Get Word32)
-- Int64s are written as a 4 bytes in big endian format
instance Binary Int64 where
put i = put (fromIntegral i :: Word64)
get = fmap fromIntegral (get :: Get Word64)
------------------------------------------------------------------------
-- Words are are written as Word64s, that is, 8 bytes in big endian format
instance Binary Word where
put i = put (fromIntegral i :: Word64)
get = fmap fromIntegral (get :: Get Word64)
-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Binary Int where
put i = put (fromIntegral i :: Int64)
get = fmap fromIntegral (get :: Get Int64)
------------------------------------------------------------------------
--
-- Portable, and pretty efficient, serialisation of Integer
--
-- Fixed-size type for a subset of Integer
type SmallInt = Int32
-- Integers are encoded in two ways: if they fit inside a SmallInt,
-- they're written as a byte tag, and that value. If the Integer value
-- is too large to fit in a SmallInt, it is written as a byte array,
-- along with a sign and length field.
instance Binary Integer where
{-# INLINE put #-}
put n | n >= lo && n <= hi = do
putWord8 0
put (fromIntegral n :: SmallInt) -- fast path
where
lo = fromIntegral (minBound :: SmallInt) :: Integer
hi = fromIntegral (maxBound :: SmallInt) :: Integer
put n = do
putWord8 1
put sign
put (unroll (abs n)) -- unroll the bytes
where
sign = fromIntegral (signum n) :: Word8
{-# INLINE get #-}
get = do
tag <- get :: Get Word8
case tag of
0 -> fmap fromIntegral (get :: Get SmallInt)
_ -> do sign <- get
bytes <- get
let v = roll bytes
return $! if sign == (1 :: Word8) then v else - v
--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: Integer -> [Word8]
unroll = unfoldr step
where
step 0 = Nothing
step i = Just (fromIntegral i, i `shiftR` 8)
roll :: [Word8] -> Integer
roll = foldr unstep 0
where
unstep b a = a `shiftL` 8 .|. fromIntegral b
{-
--
-- An efficient, raw serialisation for Integer (GHC only)
--
-- TODO This instance is not architecture portable. GMP stores numbers as
-- arrays of machine sized words, so the byte format is not portable across
-- architectures with different endianness and word size.
import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
import GHC.Base hiding (ord, chr)
import GHC.Prim
import GHC.Ptr (Ptr(..))
import GHC.IOBase (IO(..))
instance Binary Integer where
put (S# i) = putWord8 0 *> put (I# i)
put (J# s ba) = do
putWord8 1
put (I# s)
put (BA ba)
get = do
b <- getWord8
case b of
0 -> do (I# i#) <- get
return (S# i#)
_ -> do (I# s#) <- get
(BA a#) <- get
return (J# s# a#)
instance Binary ByteArray where
-- Pretty safe.
put (BA ba) =
let sz = sizeofByteArray# ba -- (primitive) in *bytes*
addr = byteArrayContents# ba
bs = unsafePackAddress (I# sz) addr
in put bs -- write as a ByteString. easy, yay!
-- Pretty scary. Should be quick though
get = do
(fp, off, n@(I# sz)) <- fmap toForeignPtr get -- so decode a ByteString
assert (off == 0) $ return $ unsafePerformIO $ do
(MBA arr) <- newByteArray sz -- and copy it into a ByteArray#
let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
freezeByteArray arr
-- wrapper for ByteArray#
data ByteArray = BA {-# UNPACK #-} !ByteArray#
data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)
newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
case newPinnedByteArray# sz s of { (# s', arr #) ->
(# s', MBA arr #) }
freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
(# s', BA arr' #) }
-}
instance (Binary a,Integral a) => Binary (R.Ratio a) where
put r = put (R.numerator r) *> put (R.denominator r)
get = (R.%) <$> get <*> get
------------------------------------------------------------------------
-- Char is serialised as UTF-8
instance Binary Char where
put a | c <= 0x7f = put (fromIntegral c :: Word8)
| c <= 0x7ff = do put (0xc0 .|. y)
put (0x80 .|. z)
| c <= 0xffff = do put (0xe0 .|. x)
put (0x80 .|. y)
put (0x80 .|. z)
| c <= 0x10ffff = do put (0xf0 .|. w)
put (0x80 .|. x)
put (0x80 .|. y)
put (0x80 .|. z)
| otherwise = error "Not a valid Unicode code point"
where
c = ord a
z, y, x, w :: Word8
z = fromIntegral (c .&. 0x3f)
y = fromIntegral (shiftR c 6 .&. 0x3f)
x = fromIntegral (shiftR c 12 .&. 0x3f)
w = fromIntegral (shiftR c 18 .&. 0x7)
get = do
let getByte = fmap (fromIntegral :: Word8 -> Int) get
shiftL6 = flip shiftL 6 :: Int -> Int
w <- getByte
r <- case () of
_ | w < 0x80 -> return w
| w < 0xe0 -> do
x <- fmap (xor 0x80) getByte
return (x .|. shiftL6 (xor 0xc0 w))
| w < 0xf0 -> do
x <- fmap (xor 0x80) getByte
y <- fmap (xor 0x80) getByte
return (y .|. shiftL6 (x .|. shiftL6
(xor 0xe0 w)))
| otherwise -> do
x <- fmap (xor 0x80) getByte
y <- fmap (xor 0x80) getByte
z <- fmap (xor 0x80) getByte
return (z .|. shiftL6 (y .|. shiftL6
(x .|. shiftL6 (xor 0xf0 w))))
return $! chr r
------------------------------------------------------------------------
-- Instances for the first few tuples
instance (Binary a, Binary b) => Binary (a,b) where
put (a,b) = put a *> put b
get = (,) <$> get <*> get
instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
put (a,b,c) = put a *> put b *> put c
get = (,,) <$> get <*> get <*> get
instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
put (a,b,c,d) = put a *> put b *> put c *> put d
get = (,,,) <$> get <*> get <*> get <*> get
instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
put (a,b,c,d,e) = put a *> put b *> put c *> put d *> put e
get = (,,,,) <$> get <*> get <*> get <*> get <*> get
--
-- and now just recurse:
--
instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
=> Binary (a,b,c,d,e,f) where
put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))
get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)
instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
=> Binary (a,b,c,d,e,f,g) where
put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h)
=> Binary (a,b,c,d,e,f,g,h) where
put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h, Binary i)
=> Binary (a,b,c,d,e,f,g,h,i) where
put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h, Binary i, Binary j)
=> Binary (a,b,c,d,e,f,g,h,i,j) where
put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)
------------------------------------------------------------------------
-- Container types
instance Binary a => Binary [a] where
put l = put (length l) *> traverse_ put l
get = do n <- get :: Get Int
getMany n
-- | 'getMany n' get 'n' elements in order, without blowing the stack.
getMany :: Binary a => Int -> Get [a]
getMany n = go [] n
where
go xs 0 = return $! reverse xs
go xs i = do x <- get
-- we must seq x to avoid stack overflows due to laziness in
-- (>>=)
x `seq` go (x:xs) (i-1)
{-# INLINE getMany #-}
instance (Binary a) => Binary (Maybe a) where
put Nothing = putWord8 0
put (Just x) = putWord8 1 *> put x
get = do
w <- getWord8
case w of
0 -> return Nothing
_ -> fmap Just get
instance (Binary a, Binary b) => Binary (Either a b) where
put (Left a) = putWord8 0 *> put a
put (Right b) = putWord8 1 *> put b
get = do
w <- getWord8
case w of
0 -> fmap Left get
_ -> fmap Right get
------------------------------------------------------------------------
-- ByteStrings (have specially efficient instances)
instance Binary B.ByteString where
put bs = do put (B.length bs)
putByteString bs
get = get >>= getByteString
--
-- Using old versions of fps, this is a type synonym, and non portable
--
-- Requires 'flexible instances'
--
instance Binary ByteString where
put bs = do put (fromIntegral (L.length bs) :: Int)
putLazyByteString bs
get = get >>= getLazyByteString
------------------------------------------------------------------------
-- Maps and Sets
instance (Binary a) => Binary (Set.Set a) where
put s = put (Set.size s) *> traverse_ put (Set.toAscList s)
get = fmap Set.fromDistinctAscList get
instance (Binary k, Binary e) => Binary (Map.Map k e) where
put m = put (Map.size m) *> traverse_ put (Map.toAscList m)
get = fmap Map.fromDistinctAscList get
instance Binary IntSet.IntSet where
put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s)
get = fmap IntSet.fromDistinctAscList get
instance (Binary e) => Binary (IntMap.IntMap e) where
put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m)
get = fmap IntMap.fromDistinctAscList get
------------------------------------------------------------------------
-- Queues and Sequences
instance (Binary e) => Binary (Seq.Seq e) where
put s = put (Seq.length s) *> Fold.traverse_ put s
get = do n <- get :: Get Int
rep Seq.empty n get
where rep xs 0 _ = return $! xs
rep xs n g = xs `seq` n `seq` do
x <- g
rep (xs Seq.|> x) (n-1) g
------------------------------------------------------------------------
-- Floating point
instance Binary Double where
put d = put (decodeFloat d)
get = encodeFloat <$> get <*> get
instance Binary Float where
put f = put (decodeFloat f)
get = encodeFloat <$> get <*> get
------------------------------------------------------------------------
-- Trees
instance (Binary e) => Binary (T.Tree e) where
put (T.Node r s) = put r *> put s
get = T.Node <$> get <*> get
------------------------------------------------------------------------
-- Arrays
instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- write the length
traverse_ put (elems a) -- now the elems.
get = do
bs <- get
n <- get -- read the length
xs <- getMany n -- now the elems.
return (listArray bs xs)
--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- now write the length
traverse_ put (elems a)
get = do
bs <- get
n <- get
xs <- getMany n
return (listArray bs xs)
{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.Binary.Generic
-- Copyright : Bryan O'Sullivan
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Bryan O'Sullivan <bos@serpentine.com>
-- Stability : unstable
-- Portability : Only works with GHC 7.2 and newer
--
-- Instances for supporting GHC generics.
--
-----------------------------------------------------------------------------
module Distribution.Compat.Binary.Generic
(
) where
import Control.Applicative
import Distribution.Compat.Binary.Class
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.Word
import GHC.Generics
-- Type without constructors
instance GBinary V1 where
gput _ = return ()
gget = return undefined
-- Constructor without arguments
instance GBinary U1 where
gput U1 = return ()
gget = return U1
-- Product: constructor with parameters
instance (GBinary a, GBinary b) => GBinary (a :*: b) where
gput (x :*: y) = gput x >> gput y
gget = (:*:) <$> gget <*> gget
-- Metadata (constructor name, etc)
instance GBinary a => GBinary (M1 i c a) where
gput = gput . unM1
gget = M1 <$> gget
-- Constants, additional parameters, and rank-1 recursion
instance Binary a => GBinary (K1 i a) where
gput = put . unK1
gget = K1 <$> get
-- Borrowed from the cereal package.
-- The following GBinary instance for sums has support for serializing
-- types with up to 2^64-1 constructors. It will use the minimal
-- number of bytes needed to encode the constructor. For example when
-- a type has 2^8 constructors or less it will use a single byte to
-- encode the constructor. If it has 2^16 constructors or less it will
-- use two bytes, and so on till 2^64-1.
#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
instance ( GSum a, GSum b
, GBinary a, GBinary b
, SumSize a, SumSize b) => GBinary (a :+: b) where
gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
| otherwise = sizeError "encode" size
where
size = unTagged (sumSize :: Tagged (a :+: b) Word64)
gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
| otherwise = sizeError "decode" size
where
size = unTagged (sumSize :: Tagged (a :+: b) Word64)
sizeError :: Show size => String -> size -> error
sizeError s size =
error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"
------------------------------------------------------------------------
checkGetSum :: (Ord word, Num word, Bits word, GSum f)
=> word -> word -> Get (f a)
checkGetSum size code | code < size = getSum code size
| otherwise = fail "Unknown encoding for constructor"
{-# INLINE checkGetSum #-}
class GSum f where
getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where
getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
| otherwise = R1 <$> getSum (code - sizeL) sizeR
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
putSum !code !size s = case s of
L1 x -> putSum code sizeL x
R1 x -> putSum (code + sizeL) sizeR x
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
instance GBinary a => GSum (C1 c a) where
getSum _ _ = gget
putSum !code _ x = put code *> gput x
------------------------------------------------------------------------
class SumSize f where
sumSize :: Tagged f Word64
newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}
instance (SumSize a, SumSize b) => SumSize (a :+: b) where
sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +
unTagged (sumSize :: Tagged b Word64)
instance SumSize (C1 c a) where
sumSize = Tagged 1
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.CharParsing
-- Copyright : (c) Edward Kmett 2011
-- License : BSD3
--
-- Maintainer : ekmett@gmail.com
-- Stability : experimental
-- Portability : non-portable
--
-- Parsers for character streams
--
-- Originally in @parsers@ package.
--
-----------------------------------------------------------------------------
module Distribution.Compat.CharParsing
(
-- * Combinators
oneOf -- :: CharParsing m => [Char] -> m Char
, noneOf -- :: CharParsing m => [Char] -> m Char
, spaces -- :: CharParsing m => m ()
, space -- :: CharParsing m => m Char
, newline -- :: CharParsing m => m Char
, tab -- :: CharParsing m => m Char
, upper -- :: CharParsing m => m Char
, lower -- :: CharParsing m => m Char
, alphaNum -- :: CharParsing m => m Char
, letter -- :: CharParsing m => m Char
, digit -- :: CharParsing m => m Char
, hexDigit -- :: CharParsing m => m Char
, octDigit -- :: CharParsing m => m Char
, satisfyRange -- :: CharParsing m => Char -> Char -> m Char
-- * Class
, CharParsing(..)
-- * Cabal additions
, integral
, munch1
, munch
, skipSpaces1
, module Distribution.Compat.Parsing
) where
import Prelude ()
import Distribution.Compat.Prelude
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Char
import Data.Text (Text, unpack)
import qualified Text.Parsec as Parsec
import Distribution.Compat.Parsing
-- | @oneOf cs@ succeeds if the current character is in the supplied
-- list of characters @cs@. Returns the parsed character. See also
-- 'satisfy'.
--
-- > vowel = oneOf "aeiou"
oneOf :: CharParsing m => [Char] -> m Char
oneOf xs = satisfy (\c -> c `elem` xs)
{-# INLINE oneOf #-}
-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current
-- character is /not/ in the supplied list of characters @cs@. Returns the
-- parsed character.
--
-- > consonant = noneOf "aeiou"
noneOf :: CharParsing m => [Char] -> m Char
noneOf xs = satisfy (\c -> c `notElem` xs)
{-# INLINE noneOf #-}
-- | Skips /zero/ or more white space characters. See also 'skipMany'.
spaces :: CharParsing m => m ()
spaces = skipMany space <?> "white space"
{-# INLINE spaces #-}
-- | Parses a white space character (any character which satisfies 'isSpace')
-- Returns the parsed character.
space :: CharParsing m => m Char
space = satisfy isSpace <?> "space"
{-# INLINE space #-}
-- | Parses a newline character (\'\\n\'). Returns a newline character.
newline :: CharParsing m => m Char
newline = char '\n' <?> "new-line"
{-# INLINE newline #-}
-- | Parses a tab character (\'\\t\'). Returns a tab character.
tab :: CharParsing m => m Char
tab = char '\t' <?> "tab"
{-# INLINE tab #-}
-- | Parses an upper case letter. Returns the parsed character.
upper :: CharParsing m => m Char
upper = satisfy isUpper <?> "uppercase letter"
{-# INLINE upper #-}
-- | Parses a lower case character. Returns the parsed character.
lower :: CharParsing m => m Char
lower = satisfy isLower <?> "lowercase letter"
{-# INLINE lower #-}
-- | Parses a letter or digit. Returns the parsed character.
alphaNum :: CharParsing m => m Char
alphaNum = satisfy isAlphaNum <?> "letter or digit"
{-# INLINE alphaNum #-}
-- | Parses a letter (an upper case or lower case character). Returns the
-- parsed character.
letter :: CharParsing m => m Char
letter = satisfy isAlpha <?> "letter"
{-# INLINE letter #-}
-- | Parses a digit. Returns the parsed character.
digit :: CharParsing m => m Char
digit = satisfy isDigit <?> "digit"
{-# INLINE digit #-}
-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and
-- \'f\' or \'A\' and \'F\'). Returns the parsed character.
hexDigit :: CharParsing m => m Char
hexDigit = satisfy isHexDigit <?> "hexadecimal digit"
{-# INLINE hexDigit #-}
-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns
-- the parsed character.
octDigit :: CharParsing m => m Char
octDigit = satisfy isOctDigit <?> "octal digit"
{-# INLINE octDigit #-}
satisfyRange :: CharParsing m => Char -> Char -> m Char
satisfyRange a z = satisfy (\c -> c >= a && c <= z)
{-# INLINE satisfyRange #-}
-- | Additional functionality needed to parse character streams.
class Parsing m => CharParsing m where
-- | Parse a single character of the input, with UTF-8 decoding
satisfy :: (Char -> Bool) -> m Char
-- | @char c@ parses a single character @c@. Returns the parsed
-- character (i.e. @c@).
--
-- /e.g./
--
-- @semiColon = 'char' ';'@
char :: Char -> m Char
char c = satisfy (c ==) <?> show [c]
{-# INLINE char #-}
-- | @notChar c@ parses any single character other than @c@. Returns the parsed
-- character.
notChar :: Char -> m Char
notChar c = satisfy (c /=)
{-# INLINE notChar #-}
-- | This parser succeeds for any character. Returns the parsed character.
anyChar :: m Char
anyChar = satisfy (const True)
{-# INLINE anyChar #-}
-- | @string s@ parses a sequence of characters given by @s@. Returns
-- the parsed string (i.e. @s@).
--
-- > divOrMod = string "div"
-- > <|> string "mod"
string :: String -> m String
string s = s <$ try (traverse_ char s) <?> show s
{-# INLINE string #-}
-- | @text t@ parses a sequence of characters determined by the text @t@ Returns
-- the parsed text fragment (i.e. @t@).
--
-- Using @OverloadedStrings@:
--
-- > divOrMod = text "div"
-- > <|> text "mod"
text :: Text -> m Text
text t = t <$ string (unpack t)
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where
satisfy = Parsec.satisfy
char = Parsec.char
notChar c = Parsec.satisfy (/= c)
anyChar = Parsec.anyChar
string = Parsec.string
-------------------------------------------------------------------------------
-- Our additions
-------------------------------------------------------------------------------
integral :: (CharParsing m, Integral a) => m a
integral = toNumber <$> some d <?> "integral"
where
toNumber = foldl' (\a b -> a * 10 + b) 0
d = f <$> satisfyRange '0' '9'
f '0' = 0
f '1' = 1
f '2' = 2
f '3' = 3
f '4' = 4
f '5' = 5
f '6' = 6
f '7' = 7
f '8' = 8
f '9' = 9
f _ = error "panic! integral"
{-# INLINE integral #-}
-- | Greedily munch characters while predicate holds.
-- Require at least one character.
munch1 :: CharParsing m => (Char -> Bool) -> m String
munch1 = some . satisfy
{-# INLINE munch1 #-}
-- | Greedely munch characters while predicate holds.
-- Always succeeds.
munch :: CharParsing m => (Char -> Bool) -> m String
munch = many . satisfy
{-# INLINE munch #-}
skipSpaces1 :: CharParsing m => m ()
skipSpaces1 = skipSome space
{-# INLINE skipSpaces1 #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
module Distribution.Compat.CopyFile (
copyFile,
copyFileChanged,
filesEqual,
copyOrdinaryFile,
copyExecutableFile,
setFileOrdinary,
setFileExecutable,
setDirOrdinary,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Exception
#ifndef mingw32_HOST_OS
import Distribution.Compat.Internal.TempFile
import Control.Exception
( bracketOnError, throwIO )
import qualified Data.ByteString.Lazy as BSL
import System.IO.Error
( ioeSetLocation )
import System.Directory
( doesFileExist, renameFile, removeFile )
import System.FilePath
( takeDirectory )
import System.IO
( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize
, withBinaryFile )
import Foreign
( allocaBytes )
import System.Posix.Types
( FileMode )
import System.Posix.Internals
( c_chmod, withFilePath )
import Foreign.C
( throwErrnoPathIfMinus1_ )
#else /* else mingw32_HOST_OS */
import Control.Exception
( throwIO )
import qualified Data.ByteString.Lazy as BSL
import System.IO.Error
( ioeSetLocation )
import System.Directory
( doesFileExist )
import System.FilePath
( addTrailingPathSeparator
, hasTrailingPathSeparator
, isPathSeparator
, isRelative
, joinDrive
, joinPath
, pathSeparator
, pathSeparators
, splitDirectories
, splitDrive
)
import System.IO
( IOMode(ReadMode), hFileSize
, withBinaryFile )
import qualified System.Win32.File as Win32 ( copyFile )
#endif /* mingw32_HOST_OS */
copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
#ifndef mingw32_HOST_OS
setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
setFileMode :: FilePath -> FileMode -> IO ()
setFileMode name m =
withFilePath name $ \s -> do
throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
#else
setFileOrdinary _ = return ()
setFileExecutable _ = return ()
#endif
-- This happens to be true on Unix and currently on Windows too:
setDirOrdinary = setFileExecutable
-- | Copies a file to a new destination.
-- Often you should use `copyFileChanged` instead.
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
copy
`catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))
where
#ifndef mingw32_HOST_OS
copy = withBinaryFile fromFPath ReadMode $ \hFrom ->
bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
do allocaBytes bufferSize $ copyContents hFrom hTmp
hClose hTmp
renameFile tmpFPath toFPath
openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
cleanTmp (tmpFPath, hTmp) = do
hClose hTmp `catchIO` \_ -> return ()
removeFile tmpFPath `catchIO` \_ -> return ()
bufferSize = 4096
copyContents hFrom hTo buffer = do
count <- hGetBuf hFrom buffer bufferSize
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
#else
copy = Win32.copyFile (toExtendedLengthPath fromFPath)
(toExtendedLengthPath toFPath)
False
-- NOTE: Shamelessly lifted from System.Directory.Internal.Windows
-- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains
-- unchanged if the prefix is not added. This function can sometimes be used
-- to bypass the @MAX_PATH@ length restriction in Windows API calls.
--
-- See Note [Path normalization].
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath path
| isRelative path = path
| otherwise =
case normalisedPath of
'\\' : '?' : '?' : '\\' : _ -> normalisedPath
'\\' : '\\' : '?' : '\\' : _ -> normalisedPath
'\\' : '\\' : '.' : '\\' : _ -> normalisedPath
'\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
_ -> "\\\\?\\" <> normalisedPath
where normalisedPath = simplifyWindows path
-- | Similar to 'normalise' but:
--
-- * empty paths stay empty,
-- * parent dirs (@..@) are expanded, and
-- * paths starting with @\\\\?\\@ are preserved.
--
-- The goal is to preserve the meaning of paths better than 'normalise'.
--
-- Note [Path normalization]
-- 'normalise' doesn't simplify path names but will convert / into \\
-- this would normally not be a problem as once the path hits the RTS we would
-- have simplified the path then. However since we're calling the WIn32 API
-- directly we have to do the simplification before the call. Without this the
-- path Z:// would become Z:\\\\ and when converted to a device path the path
-- becomes \\?\Z:\\\\ which is an invalid path.
--
-- This is not a bug in normalise as it explicitly states that it won't simplify
-- a FilePath.
simplifyWindows :: FilePath -> FilePath
simplifyWindows "" = ""
simplifyWindows path =
case drive' of
"\\\\?\\" -> drive' <> subpath
_ -> simplifiedPath
where
simplifiedPath = joinDrive drive' subpath'
(drive, subpath) = splitDrive path
drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
subpath' = appendSep . avoidEmpty . prependSep . joinPath .
stripPardirs . expandDots . skipSeps .
splitDirectories $ subpath
upperDrive d = case d of
c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s
_ -> d
skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")
| otherwise = id
prependSep | subpathIsAbsolute = (pathSeparator :)
| otherwise = id
avoidEmpty | not pathIsAbsolute
&& (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."
= emptyToCurDir
| otherwise = id
appendSep p | hasTrailingPathSep
&& not (pathIsAbsolute && null p)
= addTrailingPathSeparator p
| otherwise = p
pathIsAbsolute = not (isRelative path)
subpathIsAbsolute = any isPathSeparator (take 1 subpath)
hasTrailingPathSep = hasTrailingPathSeparator subpath
-- | Given a list of path segments, expand @.@ and @..@. The path segments
-- must not contain path separators.
expandDots :: [FilePath] -> [FilePath]
expandDots = reverse . go []
where
go ys' xs' =
case xs' of
[] -> ys'
x : xs ->
case x of
"." -> go ys' xs
".." ->
case ys' of
[] -> go (x : ys') xs
".." : _ -> go (x : ys') xs
_ : ys -> go ys xs
_ -> go (x : ys') xs
-- | Convert to the right kind of slashes.
normalisePathSeps :: FilePath -> FilePath
normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p
-- | Remove redundant trailing slashes and pick the right kind of slash.
normaliseTrailingSep :: FilePath -> FilePath
normaliseTrailingSep path = do
let path' = reverse path
let (sep, path'') = span isPathSeparator path'
let addSep = if null sep then id else (pathSeparator :)
reverse (addSep path'')
-- | Convert empty paths to the current directory, otherwise leave it
-- unchanged.
emptyToCurDir :: FilePath -> FilePath
emptyToCurDir "" = "."
emptyToCurDir path = path
#endif /* mingw32_HOST_OS */
-- | Like `copyFile`, but does not touch the target if source and destination
-- are already byte-identical. This is recommended as it is useful for
-- time-stamp based recompilation avoidance.
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged src dest = do
equal <- filesEqual src dest
unless equal $ copyFile src dest
-- | Checks if two files are byte-identical.
-- Returns False if either of the files do not exist or if files
-- are of different size.
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual f1 f2 = do
ex1 <- doesFileExist f1
ex2 <- doesFileExist f2
if not (ex1 && ex2) then return False else
withBinaryFile f1 ReadMode $ \h1 ->
withBinaryFile f2 ReadMode $ \h2 -> do
s1 <- hFileSize h1
s2 <- hFileSize h2
if s1 /= s2
then return False
else do
c1 <- BSL.hGetContents h1
c2 <- BSL.hGetContents h2
return $! c1 == c2
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Compat.CreatePipe (createPipe) where
import System.IO (Handle, hSetEncoding, localeEncoding)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Stack
-- The mingw32_HOST_OS CPP macro is GHC-specific
#ifdef mingw32_HOST_OS
import qualified Prelude
import Control.Exception (onException)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.Ptr (Ptr)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Storable (peek, peekElemOff)
import GHC.IO.FD (mkFD)
import GHC.IO.Device (IODeviceType(Stream))
import GHC.IO.Handle.FD (mkHandleFromFD)
import System.IO (IOMode(ReadMode, WriteMode))
#elif defined ghcjs_HOST_OS
#else
import System.Posix.IO (fdToHandle)
import qualified System.Posix.IO as Posix
#endif
createPipe :: IO (Handle, Handle)
-- The mingw32_HOST_OS CPP macro is GHC-specific
#ifdef mingw32_HOST_OS
createPipe = do
(readfd, writefd) <- allocaArray 2 $ \ pfds -> do
throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)
readfd <- peek pfds
writefd <- peekElemOff pfds 1
return (readfd, writefd)
(do readh <- fdToHandle readfd ReadMode
writeh <- fdToHandle writefd WriteMode
hSetEncoding readh localeEncoding
hSetEncoding writeh localeEncoding
return (readh, writeh)) `onException` (close readfd >> close writefd)
where
fdToHandle :: CInt -> IOMode -> IO Handle
fdToHandle fd mode = do
(fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
mkHandleFromFD fd' deviceType "" mode False Nothing
close :: CInt -> IO ()
close = throwErrnoIfMinus1_ "_close" . c__close
where _ = callStack -- TODO: attach call stack to exception
_ = callStack -- TODO: attach call stack to exceptions
foreign import ccall "io.h _pipe" c__pipe ::
Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt
foreign import ccall "io.h _close" c__close ::
CInt -> Prelude.IO CInt
#elif defined ghcjs_HOST_OS
createPipe = error "createPipe"
where
_ = callStack
#else
createPipe = do
(readfd, writefd) <- Posix.createPipe
readh <- fdToHandle readfd
writeh <- fdToHandle writefd
hSetEncoding readh localeEncoding
hSetEncoding writeh localeEncoding
return (readh, writeh)
where
_ = callStack
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.DList
-- Copyright : (c) Ben Gamari 2015-2019
-- License : BSD3
--
-- Maintainer : cabal-dev@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- A very simple difference list.
module Distribution.Compat.DList (
DList,
runDList,
empty,
singleton,
fromList,
toList,
snoc,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (toList, empty)
-- | Difference list.
newtype DList a = DList ([a] -> [a])
runDList :: DList a -> [a]
runDList (DList run) = run []
-- | Make 'DList' with containing single element.
singleton :: a -> DList a
singleton a = DList (a:)
empty :: DList a
empty = DList id
fromList :: [a] -> DList a
fromList as = DList (as ++)
toList :: DList a -> [a]
toList = runDList
snoc :: DList a -> a -> DList a
snoc xs x = xs <> singleton x
instance Monoid (DList a) where
mempty = empty
mappend = (<>)
instance Semigroup (DList a) where
DList a <> DList b = DList (a . b)