{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Backpack.UnifyM (
UnifyM,
runUnifyM,
failWith,
addErr,
failIfErrs,
tryM,
addErrContext,
addErrContextM,
liftST,
UnifEnv(..),
getUnifEnv,
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.Text
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
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
newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) }
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)))
type ErrCtx s = MsgDoc
data UnifEnv s = UnifEnv {
unify_uniq :: UnifRef s UnitIdUnique,
unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),
unify_self_cid :: ComponentId,
unify_verbosity :: Verbosity,
unify_ctx :: [ErrCtx s],
unify_db :: FullDb,
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
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))
type UnifRef s a = STRef s a
readUnifRef :: UnifRef s a -> UnifyM s a
readUnifRef = liftST . readSTRef
writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
writeUnifRef x = liftST . writeSTRef x
getUnifEnv :: UnifyM s (UnifEnv s)
getUnifEnv = UnifyM $ \r -> return (return r)
addErrContext :: Doc -> UnifyM s a -> UnifyM s a
addErrContext ctx m = addErrContextM ctx m
addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
addErrContextM ctx m =
UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r }
data ModuleU' s
= ModuleU (UnitIdU s) ModuleName
| ModuleVarU ModuleName
data UnitIdU' s
= UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
| UnitIdThunkU DefUnitId
type ModuleU s = UnionFind.Point s (ModuleU' s)
type UnitIdU s = UnionFind.Point s (UnitIdU' s)
type UnitIdUnique = Int
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)
emptyMuEnv :: MuEnv s
emptyMuEnv = (IntMap.empty, -1)
convertUnitId' :: MuEnv s
-> OpenUnitId
-> UnifyM s (UnitIdU s)
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")
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
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
type ModuleSubstU s = Map ModuleName (ModuleU s)
convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst = T.mapM convertModule
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU = T.mapM convertModuleU
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)
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")
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)
convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU = convertUnitIdU' emptyMooEnv
convertModuleU :: ModuleU s -> UnifyM s OpenModule
convertModuleU = convertModuleU' emptyMooEnv
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU = (Map.empty, Map.empty)
type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)
type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]
type ModuleRequiresU s = ModuleProvidesU s
type ModuleWithSourceU s = WithSource (ModuleU s)
ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
ci_msg ci
| ci_implicit ci = text "build-depends:" <+> pp_pn
| otherwise = text "mixins:" <+> pp_pn <+> disp (ci_renaming ci)
where
pn = pkgName (ci_pkgid ci)
pp_pn =
case ci_cname ci of
CLibName -> disp pn
CSubLibName cn -> disp pn <<>> colon <<>> disp cn
cn -> disp pn <+> parens (disp cn)
convertInclude
:: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM s (ModuleScopeU s,
Either (ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming) )
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
req_rename_list <-
case req_rns of
DefaultRenaming -> return []
HidingRenaming _ -> do
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 (disp k) $$
text "Renamed to: " <+> vcat (map disp (v:vs))
return v
let req_rename_fn k = case Map.lookup k req_rename of
Nothing -> k
Just v -> v
let req_subst = fmap OpenModuleVar req_rename
uid_u <- convertUnitId (modSubst req_subst uid)
reqs_u <- convertModuleRequires . Map.fromList $
[ (k, [source (OpenModuleVar k)])
| k <- map req_rename_fn (Set.toList reqs)
]
let leftover = Map.keysSet req_rename `Set.difference` reqs
unless (Set.null leftover) $
addErr $
hang (text "The" <+> text (showComponentName compname) <+>
text "from package" <+> quotes (disp pid)
<+> text "does not require:") 4
(vcat (map disp (Set.toList leftover)))
(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) ]
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 (disp pid) <+>
text "does not expose the module" <+> quotes (disp 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
return ((provs_u, reqs_u),
(if Map.null provs && not (Set.null reqs)
then Right
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
}))
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU (provs_u, reqs_u) = do
provs <- convertModuleProvidesU provs_u
reqs <- convertModuleRequiresU reqs_u
return (ModuleScope provs reqs)
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
convertModuleProvides = T.mapM (mapM (T.mapM convertModule))
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