{-# 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.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
data ErrMsg = ErrMsg {
ErrMsg -> Doc
err_msg :: Doc,
ErrMsg -> [Doc]
err_ctx :: [Doc]
}
type MsgDoc = Doc
renderErrMsg :: ErrMsg -> MsgDoc
renderErrMsg :: ErrMsg -> Doc
renderErrMsg ErrMsg { err_msg :: ErrMsg -> Doc
err_msg = Doc
msg, err_ctx :: ErrMsg -> [Doc]
err_ctx = [Doc]
ctx } =
Doc
msg Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat [Doc]
ctx
newtype UnifyM s a = UnifyM { UnifyM s a -> UnifEnv s -> ST s (Maybe a)
unUnifyM :: UnifEnv s -> ST s (Maybe a) }
runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a
runUnifyM :: Verbosity
-> ComponentId
-> FullDb
-> (forall s. UnifyM s a)
-> Either [Doc] a
runUnifyM verbosity :: Verbosity
verbosity self_cid :: ComponentId
self_cid db :: FullDb
db m :: forall s. UnifyM s a
m
= (forall s. ST s (Either [Doc] a)) -> Either [Doc] a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either [Doc] a)) -> Either [Doc] a)
-> (forall s. ST s (Either [Doc] a)) -> Either [Doc] a
forall a b. (a -> b) -> a -> b
$ do STRef s UnitIdUnique
i <- UnitIdUnique -> ST s (STRef s UnitIdUnique)
forall a s. a -> ST s (STRef s a)
newSTRef 0
STRef s (Map ModuleName (ModuleU s))
hmap <- Map ModuleName (ModuleU s)
-> ST s (STRef s (Map ModuleName (ModuleU s)))
forall a s. a -> ST s (STRef s a)
newSTRef Map ModuleName (ModuleU s)
forall k a. Map k a
Map.empty
STRef s [ErrMsg]
errs <- [ErrMsg] -> ST s (STRef s [ErrMsg])
forall a s. a -> ST s (STRef s a)
newSTRef []
Maybe a
mb_r <- UnifyM s a -> UnifEnv s -> ST s (Maybe a)
forall s a. UnifyM s a -> UnifEnv s -> ST s (Maybe a)
unUnifyM UnifyM s a
forall s. UnifyM s a
m UnifEnv :: forall s.
UnifRef s UnitIdUnique
-> UnifRef s (Map ModuleName (ModuleU s))
-> ComponentId
-> Verbosity
-> [Doc]
-> FullDb
-> UnifRef s [ErrMsg]
-> UnifEnv s
UnifEnv {
unify_uniq :: STRef s UnitIdUnique
unify_uniq = STRef s UnitIdUnique
i,
unify_reqs :: STRef s (Map ModuleName (ModuleU s))
unify_reqs = STRef s (Map ModuleName (ModuleU s))
hmap,
unify_self_cid :: ComponentId
unify_self_cid = ComponentId
self_cid,
unify_verbosity :: Verbosity
unify_verbosity = Verbosity
verbosity,
unify_ctx :: [Doc]
unify_ctx = [],
unify_db :: FullDb
unify_db = FullDb
db,
unify_errs :: STRef s [ErrMsg]
unify_errs = STRef s [ErrMsg]
errs }
[ErrMsg]
final_errs <- STRef s [ErrMsg] -> ST s [ErrMsg]
forall s a. STRef s a -> ST s a
readSTRef STRef s [ErrMsg]
errs
case Maybe a
mb_r of
Just x :: a
x | [ErrMsg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
final_errs -> Either [Doc] a -> ST s (Either [Doc] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either [Doc] a
forall a b. b -> Either a b
Right a
x)
_ -> Either [Doc] a -> ST s (Either [Doc] a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Doc] -> Either [Doc] a
forall a b. a -> Either a b
Left ((ErrMsg -> Doc) -> [ErrMsg] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ErrMsg -> Doc
renderErrMsg ([ErrMsg] -> [ErrMsg]
forall a. [a] -> [a]
reverse [ErrMsg]
final_errs)))
type ErrCtx s = MsgDoc
data UnifEnv s = UnifEnv {
UnifEnv s -> UnifRef s UnitIdUnique
unify_uniq :: UnifRef s UnitIdUnique,
UnifEnv s -> UnifRef s (Map ModuleName (ModuleU s))
unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),
UnifEnv s -> ComponentId
unify_self_cid :: ComponentId,
UnifEnv s -> Verbosity
unify_verbosity :: Verbosity,
UnifEnv s -> [Doc]
unify_ctx :: [ErrCtx s],
UnifEnv s -> FullDb
unify_db :: FullDb,
UnifEnv s -> UnifRef s [ErrMsg]
unify_errs :: UnifRef s [ErrMsg]
}
instance Functor (UnifyM s) where
fmap :: (a -> b) -> UnifyM s a -> UnifyM s b
fmap f :: a -> b
f (UnifyM m :: UnifEnv s -> ST s (Maybe a)
m) = (UnifEnv s -> ST s (Maybe b)) -> UnifyM s b
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((ST s (Maybe a) -> ST s (Maybe b))
-> (UnifEnv s -> ST s (Maybe a)) -> UnifEnv s -> ST s (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe a -> Maybe b) -> ST s (Maybe a) -> ST s (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) UnifEnv s -> ST s (Maybe a)
m)
instance Applicative (UnifyM s) where
pure :: a -> UnifyM s a
pure = (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe a)) -> UnifyM s a)
-> (a -> UnifEnv s -> ST s (Maybe a)) -> a -> UnifyM s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s (Maybe a) -> UnifEnv s -> ST s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ST s (Maybe a) -> UnifEnv s -> ST s (Maybe a))
-> (a -> ST s (Maybe a)) -> a -> UnifEnv s -> ST s (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> ST s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> ST s (Maybe a))
-> (a -> Maybe a) -> a -> ST s (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
UnifyM f :: UnifEnv s -> ST s (Maybe (a -> b))
f <*> :: UnifyM s (a -> b) -> UnifyM s a -> UnifyM s b
<*> UnifyM x :: UnifEnv s -> ST s (Maybe a)
x = (UnifEnv s -> ST s (Maybe b)) -> UnifyM s b
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe b)) -> UnifyM s b)
-> (UnifEnv s -> ST s (Maybe b)) -> UnifyM s b
forall a b. (a -> b) -> a -> b
$ \r :: UnifEnv s
r -> do
Maybe (a -> b)
f' <- UnifEnv s -> ST s (Maybe (a -> b))
f UnifEnv s
r
case Maybe (a -> b)
f' of
Nothing -> Maybe b -> ST s (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
Just f'' :: a -> b
f'' -> do
Maybe a
x' <- UnifEnv s -> ST s (Maybe a)
x UnifEnv s
r
case Maybe a
x' of
Nothing -> Maybe b -> ST s (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
Just x'' :: a
x'' -> Maybe b -> ST s (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
f'' a
x''))
instance Monad (UnifyM s) where
return :: a -> UnifyM s a
return = a -> UnifyM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
UnifyM m :: UnifEnv s -> ST s (Maybe a)
m >>= :: UnifyM s a -> (a -> UnifyM s b) -> UnifyM s b
>>= f :: a -> UnifyM s b
f = (UnifEnv s -> ST s (Maybe b)) -> UnifyM s b
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe b)) -> UnifyM s b)
-> (UnifEnv s -> ST s (Maybe b)) -> UnifyM s b
forall a b. (a -> b) -> a -> b
$ \r :: UnifEnv s
r -> do
Maybe a
x <- UnifEnv s -> ST s (Maybe a)
m UnifEnv s
r
case Maybe a
x of
Nothing -> Maybe b -> ST s (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
Just x' :: a
x' -> UnifyM s b -> UnifEnv s -> ST s (Maybe b)
forall s a. UnifyM s a -> UnifEnv s -> ST s (Maybe a)
unUnifyM (a -> UnifyM s b
f a
x') UnifEnv s
r
liftST :: ST s a -> UnifyM s a
liftST :: ST s a -> UnifyM s a
liftST m :: ST s a
m = (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe a)) -> UnifyM s a)
-> (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall a b. (a -> b) -> a -> b
$ \_ -> (a -> Maybe a) -> ST s a -> ST s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just ST s a
m
addErr :: MsgDoc -> UnifyM s ()
addErr :: Doc -> UnifyM s ()
addErr msg :: Doc
msg = do
UnifEnv s
env <- UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
let err :: ErrMsg
err = ErrMsg :: Doc -> [Doc] -> ErrMsg
ErrMsg {
err_msg :: Doc
err_msg = Doc
msg,
err_ctx :: [Doc]
err_ctx = UnifEnv s -> [Doc]
forall s. UnifEnv s -> [Doc]
unify_ctx UnifEnv s
env
}
ST s () -> UnifyM s ()
forall s a. ST s a -> UnifyM s a
liftST (ST s () -> UnifyM s ()) -> ST s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ STRef s [ErrMsg] -> ([ErrMsg] -> [ErrMsg]) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (UnifEnv s -> STRef s [ErrMsg]
forall s. UnifEnv s -> UnifRef s [ErrMsg]
unify_errs UnifEnv s
env) (\errs :: [ErrMsg]
errs -> ErrMsg
errErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:[ErrMsg]
errs)
failWith :: MsgDoc -> UnifyM s a
failWith :: Doc -> UnifyM s a
failWith msg :: Doc
msg = do
Doc -> UnifyM s ()
forall s. Doc -> UnifyM s ()
addErr Doc
msg
UnifyM s a
forall s a. UnifyM s a
failM
failM :: UnifyM s a
failM :: UnifyM s a
failM = (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe a)) -> UnifyM s a)
-> (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall a b. (a -> b) -> a -> b
$ \_ -> Maybe a -> ST s (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
failIfErrs :: UnifyM s ()
failIfErrs :: UnifyM s ()
failIfErrs = do
UnifEnv s
env <- UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
[ErrMsg]
errs <- ST s [ErrMsg] -> UnifyM s [ErrMsg]
forall s a. ST s a -> UnifyM s a
liftST (ST s [ErrMsg] -> UnifyM s [ErrMsg])
-> ST s [ErrMsg] -> UnifyM s [ErrMsg]
forall a b. (a -> b) -> a -> b
$ STRef s [ErrMsg] -> ST s [ErrMsg]
forall s a. STRef s a -> ST s a
readSTRef (UnifEnv s -> STRef s [ErrMsg]
forall s. UnifEnv s -> UnifRef s [ErrMsg]
unify_errs UnifEnv s
env)
Bool -> UnifyM s () -> UnifyM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([ErrMsg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
errs)) UnifyM s ()
forall s a. UnifyM s a
failM
tryM :: UnifyM s a -> UnifyM s (Maybe a)
tryM :: UnifyM s a -> UnifyM s (Maybe a)
tryM m :: UnifyM s a
m =
(UnifEnv s -> ST s (Maybe (Maybe a))) -> UnifyM s (Maybe a)
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM (\env :: UnifEnv s
env -> do
Maybe a
mb_r <- UnifyM s a -> UnifEnv s -> ST s (Maybe a)
forall s a. UnifyM s a -> UnifEnv s -> ST s (Maybe a)
unUnifyM UnifyM s a
m UnifEnv s
env
Maybe (Maybe a) -> ST s (Maybe (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
mb_r))
type UnifRef s a = STRef s a
readUnifRef :: UnifRef s a -> UnifyM s a
readUnifRef :: UnifRef s a -> UnifyM s a
readUnifRef = ST s a -> UnifyM s a
forall s a. ST s a -> UnifyM s a
liftST (ST s a -> UnifyM s a)
-> (UnifRef s a -> ST s a) -> UnifRef s a -> UnifyM s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnifRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef
writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
writeUnifRef x :: UnifRef s a
x = ST s () -> UnifyM s ()
forall s a. ST s a -> UnifyM s a
liftST (ST s () -> UnifyM s ()) -> (a -> ST s ()) -> a -> UnifyM s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnifRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef UnifRef s a
x
getUnifEnv :: UnifyM s (UnifEnv s)
getUnifEnv :: UnifyM s (UnifEnv s)
getUnifEnv = (UnifEnv s -> ST s (Maybe (UnifEnv s))) -> UnifyM s (UnifEnv s)
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe (UnifEnv s))) -> UnifyM s (UnifEnv s))
-> (UnifEnv s -> ST s (Maybe (UnifEnv s))) -> UnifyM s (UnifEnv s)
forall a b. (a -> b) -> a -> b
$ \r :: UnifEnv s
r -> Maybe (UnifEnv s) -> ST s (Maybe (UnifEnv s))
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifEnv s -> Maybe (UnifEnv s)
forall (m :: * -> *) a. Monad m => a -> m a
return UnifEnv s
r)
addErrContext :: Doc -> UnifyM s a -> UnifyM s a
addErrContext :: Doc -> UnifyM s a -> UnifyM s a
addErrContext ctx :: Doc
ctx m :: UnifyM s a
m = Doc -> UnifyM s a -> UnifyM s a
forall s a. Doc -> UnifyM s a -> UnifyM s a
addErrContextM Doc
ctx UnifyM s a
m
addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
addErrContextM :: Doc -> UnifyM s a -> UnifyM s a
addErrContextM ctx :: Doc
ctx m :: UnifyM s a
m =
(UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall s a. (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
UnifyM ((UnifEnv s -> ST s (Maybe a)) -> UnifyM s a)
-> (UnifEnv s -> ST s (Maybe a)) -> UnifyM s a
forall a b. (a -> b) -> a -> b
$ \r :: UnifEnv s
r -> UnifyM s a -> UnifEnv s -> ST s (Maybe a)
forall s a. UnifyM s a -> UnifEnv s -> ST s (Maybe a)
unUnifyM UnifyM s a
m UnifEnv s
r { unify_ctx :: [Doc]
unify_ctx = Doc
ctx Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: UnifEnv s -> [Doc]
forall s. UnifEnv s -> [Doc]
unify_ctx UnifEnv s
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 :: MuEnv s -> UnitIdU s -> MuEnv s
extendMuEnv (m :: IntMap (UnitIdU s)
m, i :: UnitIdUnique
i) x :: UnitIdU s
x =
(UnitIdUnique
-> UnitIdU s -> IntMap (UnitIdU s) -> IntMap (UnitIdU s)
forall a. UnitIdUnique -> a -> IntMap a -> IntMap a
IntMap.insert (UnitIdUnique
i UnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
+ 1) UnitIdU s
x IntMap (UnitIdU s)
m, UnitIdUnique
i UnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
+ 1)
emptyMuEnv :: MuEnv s
emptyMuEnv :: MuEnv s
emptyMuEnv = (IntMap (UnitIdU s)
forall a. IntMap a
IntMap.empty, -1)
convertUnitId' :: MuEnv s
-> OpenUnitId
-> UnifyM s (UnitIdU s)
convertUnitId' :: MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId' _ (DefiniteUnitId uid :: DefUnitId
uid) =
ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (UnitIdU s) -> UnifyM s (UnitIdU s))
-> ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall a b. (a -> b) -> a -> b
$ UnitIdU' s -> ST s (UnitIdU s)
forall a s. a -> ST s (Point s a)
UnionFind.fresh (DefUnitId -> UnitIdU' s
forall s. DefUnitId -> UnitIdU' s
UnitIdThunkU DefUnitId
uid)
convertUnitId' stk :: MuEnv s
stk (IndefFullUnitId cid :: ComponentId
cid insts :: OpenModuleSubst
insts) = do
UnifRef s UnitIdUnique
fs <- (UnifEnv s -> UnifRef s UnitIdUnique)
-> UnifyM s (UnifEnv s) -> UnifyM s (UnifRef s UnitIdUnique)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnifEnv s -> UnifRef s UnitIdUnique
forall s. UnifEnv s -> UnifRef s UnitIdUnique
unify_uniq UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
UnitIdU s
x <- ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (UnitIdU s) -> UnifyM s (UnitIdU s))
-> ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall a b. (a -> b) -> a -> b
$ UnitIdU' s -> ST s (UnitIdU s)
forall a s. a -> ST s (Point s a)
UnionFind.fresh ([Char] -> UnitIdU' s
forall a. HasCallStack => [Char] -> a
error "convertUnitId")
Map ModuleName (ModuleU s)
insts_u <- OpenModuleSubst
-> (OpenModule -> UnifyM s (ModuleU s))
-> UnifyM s (Map ModuleName (ModuleU s))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM OpenModuleSubst
insts ((OpenModule -> UnifyM s (ModuleU s))
-> UnifyM s (Map ModuleName (ModuleU s)))
-> (OpenModule -> UnifyM s (ModuleU s))
-> UnifyM s (Map ModuleName (ModuleU s))
forall a b. (a -> b) -> a -> b
$ MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
forall s. MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
convertModule' (MuEnv s -> UnitIdU s -> MuEnv s
forall s. MuEnv s -> UnitIdU s -> MuEnv s
extendMuEnv MuEnv s
stk UnitIdU s
x)
UnitIdUnique
u <- UnifRef s UnitIdUnique -> UnifyM s UnitIdUnique
forall s a. UnifRef s a -> UnifyM s a
readUnifRef UnifRef s UnitIdUnique
fs
UnifRef s UnitIdUnique -> UnitIdUnique -> UnifyM s ()
forall s a. UnifRef s a -> a -> UnifyM s ()
writeUnifRef UnifRef s UnitIdUnique
fs (UnitIdUnique
uUnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
+1)
UnitIdU s
y <- ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (UnitIdU s) -> UnifyM s (UnitIdU s))
-> ST s (UnitIdU s) -> UnifyM s (UnitIdU s)
forall a b. (a -> b) -> a -> b
$ UnitIdU' s -> ST s (UnitIdU s)
forall a s. a -> ST s (Point s a)
UnionFind.fresh (UnitIdUnique
-> ComponentId -> Map ModuleName (ModuleU s) -> UnitIdU' s
forall s.
UnitIdUnique
-> ComponentId -> Map ModuleName (ModuleU s) -> UnitIdU' s
UnitIdU UnitIdUnique
u ComponentId
cid Map ModuleName (ModuleU s)
insts_u)
ST s () -> UnifyM s ()
forall s a. ST s a -> UnifyM s a
liftST (ST s () -> UnifyM s ()) -> ST s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ UnitIdU s -> UnitIdU s -> ST s ()
forall s a. Point s a -> Point s a -> ST s ()
UnionFind.union UnitIdU s
x UnitIdU s
y
UnitIdU s -> UnifyM s (UnitIdU s)
forall (m :: * -> *) a. Monad m => a -> m a
return UnitIdU s
y
convertModule' :: MuEnv s
-> OpenModule -> UnifyM s (ModuleU s)
convertModule' :: MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
convertModule' _stk :: MuEnv s
_stk (OpenModuleVar mod_name :: ModuleName
mod_name) = do
UnifRef s (Map ModuleName (ModuleU s))
hmap <- (UnifEnv s -> UnifRef s (Map ModuleName (ModuleU s)))
-> UnifyM s (UnifEnv s)
-> UnifyM s (UnifRef s (Map ModuleName (ModuleU s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnifEnv s -> UnifRef s (Map ModuleName (ModuleU s))
forall s. UnifEnv s -> UnifRef s (Map ModuleName (ModuleU s))
unify_reqs UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
Map ModuleName (ModuleU s)
hm <- UnifRef s (Map ModuleName (ModuleU s))
-> UnifyM s (Map ModuleName (ModuleU s))
forall s a. UnifRef s a -> UnifyM s a
readUnifRef UnifRef s (Map ModuleName (ModuleU s))
hmap
case ModuleName -> Map ModuleName (ModuleU s) -> Maybe (ModuleU s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mod_name Map ModuleName (ModuleU s)
hm of
Nothing -> do ModuleU s
mod <- ST s (ModuleU s) -> UnifyM s (ModuleU s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (ModuleU s) -> UnifyM s (ModuleU s))
-> ST s (ModuleU s) -> UnifyM s (ModuleU s)
forall a b. (a -> b) -> a -> b
$ ModuleU' s -> ST s (ModuleU s)
forall a s. a -> ST s (Point s a)
UnionFind.fresh (ModuleName -> ModuleU' s
forall s. ModuleName -> ModuleU' s
ModuleVarU ModuleName
mod_name)
UnifRef s (Map ModuleName (ModuleU s))
-> Map ModuleName (ModuleU s) -> UnifyM s ()
forall s a. UnifRef s a -> a -> UnifyM s ()
writeUnifRef UnifRef s (Map ModuleName (ModuleU s))
hmap (ModuleName
-> ModuleU s
-> Map ModuleName (ModuleU s)
-> Map ModuleName (ModuleU s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleName
mod_name ModuleU s
mod Map ModuleName (ModuleU s)
hm)
ModuleU s -> UnifyM s (ModuleU s)
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleU s
mod
Just mod :: ModuleU s
mod -> ModuleU s -> UnifyM s (ModuleU s)
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleU s
mod
convertModule' stk :: MuEnv s
stk (OpenModule uid :: OpenUnitId
uid mod_name :: ModuleName
mod_name) = do
UnitIdU s
uid_u <- MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
forall s. MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId' MuEnv s
stk OpenUnitId
uid
ST s (ModuleU s) -> UnifyM s (ModuleU s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (ModuleU s) -> UnifyM s (ModuleU s))
-> ST s (ModuleU s) -> UnifyM s (ModuleU s)
forall a b. (a -> b) -> a -> b
$ ModuleU' s -> ST s (ModuleU s)
forall a s. a -> ST s (Point s a)
UnionFind.fresh (UnitIdU s -> ModuleName -> ModuleU' s
forall s. UnitIdU s -> ModuleName -> ModuleU' s
ModuleU UnitIdU s
uid_u ModuleName
mod_name)
convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId = MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
forall s. MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId' MuEnv s
forall s. MuEnv s
emptyMuEnv
convertModule :: OpenModule -> UnifyM s (ModuleU s)
convertModule :: OpenModule -> UnifyM s (ModuleU s)
convertModule = MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
forall s. MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
convertModule' MuEnv s
forall s. MuEnv s
emptyMuEnv
type ModuleSubstU s = Map ModuleName (ModuleU s)
convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst :: OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst = (OpenModule -> UnifyM s (ModuleU s))
-> OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU = (ModuleU s -> UnifyM s OpenModule)
-> ModuleSubstU s -> UnifyM s OpenModuleSubst
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU
type MooEnv = (IntMap Int, Int)
emptyMooEnv :: MooEnv
emptyMooEnv :: MooEnv
emptyMooEnv = (IntMap UnitIdUnique
forall a. IntMap a
IntMap.empty, -1)
extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv
extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv
extendMooEnv (m :: IntMap UnitIdUnique
m, i :: UnitIdUnique
i) k :: UnitIdUnique
k = (UnitIdUnique
-> UnitIdUnique -> IntMap UnitIdUnique -> IntMap UnitIdUnique
forall a. UnitIdUnique -> a -> IntMap a -> IntMap a
IntMap.insert UnitIdUnique
k (UnitIdUnique
i UnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
+ 1) IntMap UnitIdUnique
m, UnitIdUnique
i UnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
+ 1)
lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int
lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe UnitIdUnique
lookupMooEnv (m :: IntMap UnitIdUnique
m, i :: UnitIdUnique
i) k :: UnitIdUnique
k =
case UnitIdUnique -> IntMap UnitIdUnique -> Maybe UnitIdUnique
forall a. UnitIdUnique -> IntMap a -> Maybe a
IntMap.lookup UnitIdUnique
k IntMap UnitIdUnique
m of
Nothing -> Maybe UnitIdUnique
forall a. Maybe a
Nothing
Just v :: UnitIdUnique
v -> UnitIdUnique -> Maybe UnitIdUnique
forall a. a -> Maybe a
Just (UnitIdUnique
iUnitIdUnique -> UnitIdUnique -> UnitIdUnique
forall a. Num a => a -> a -> a
-UnitIdUnique
v)
convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU' stk :: MooEnv
stk uid_u :: UnitIdU s
uid_u = do
UnitIdU' s
x <- ST s (UnitIdU' s) -> UnifyM s (UnitIdU' s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (UnitIdU' s) -> UnifyM s (UnitIdU' s))
-> ST s (UnitIdU' s) -> UnifyM s (UnitIdU' s)
forall a b. (a -> b) -> a -> b
$ UnitIdU s -> ST s (UnitIdU' s)
forall s a. Point s a -> ST s a
UnionFind.find UnitIdU s
uid_u
case UnitIdU' s
x of
UnitIdThunkU uid :: DefUnitId
uid -> OpenUnitId -> UnifyM s OpenUnitId
forall (m :: * -> *) a. Monad m => a -> m a
return (DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid)
UnitIdU u :: UnitIdUnique
u cid :: ComponentId
cid insts_u :: Map ModuleName (ModuleU s)
insts_u ->
case MooEnv -> UnitIdUnique -> Maybe UnitIdUnique
lookupMooEnv MooEnv
stk UnitIdUnique
u of
Just _i :: UnitIdUnique
_i ->
Doc -> UnifyM s OpenUnitId
forall s a. Doc -> UnifyM s a
failWith ([Char] -> Doc
text "Unsupported mutually recursive unit identifier")
Nothing -> do
OpenModuleSubst
insts <- Map ModuleName (ModuleU s)
-> (ModuleU s -> UnifyM s OpenModule) -> UnifyM s OpenModuleSubst
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM Map ModuleName (ModuleU s)
insts_u ((ModuleU s -> UnifyM s OpenModule) -> UnifyM s OpenModuleSubst)
-> (ModuleU s -> UnifyM s OpenModule) -> UnifyM s OpenModuleSubst
forall a b. (a -> b) -> a -> b
$ MooEnv -> ModuleU s -> UnifyM s OpenModule
forall s. MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' (MooEnv -> UnitIdUnique -> MooEnv
extendMooEnv MooEnv
stk UnitIdUnique
u)
OpenUnitId -> UnifyM s OpenUnitId
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
insts)
convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' stk :: MooEnv
stk mod_u :: ModuleU s
mod_u = do
ModuleU' s
mod <- ST s (ModuleU' s) -> UnifyM s (ModuleU' s)
forall s a. ST s a -> UnifyM s a
liftST (ST s (ModuleU' s) -> UnifyM s (ModuleU' s))
-> ST s (ModuleU' s) -> UnifyM s (ModuleU' s)
forall a b. (a -> b) -> a -> b
$ ModuleU s -> ST s (ModuleU' s)
forall s a. Point s a -> ST s a
UnionFind.find ModuleU s
mod_u
case ModuleU' s
mod of
ModuleVarU mod_name :: ModuleName
mod_name -> OpenModule -> UnifyM s OpenModule
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> OpenModule
OpenModuleVar ModuleName
mod_name)
ModuleU uid_u :: UnitIdU s
uid_u mod_name :: ModuleName
mod_name -> do
OpenUnitId
uid <- MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
forall s. MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU' MooEnv
stk UnitIdU s
uid_u
OpenModule -> UnifyM s OpenModule
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
uid ModuleName
mod_name)
convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU = MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
forall s. MooEnv -> UnitIdU s -> UnifyM s OpenUnitId
convertUnitIdU' MooEnv
emptyMooEnv
convertModuleU :: ModuleU s -> UnifyM s OpenModule
convertModuleU :: ModuleU s -> UnifyM s OpenModule
convertModuleU = MooEnv -> ModuleU s -> UnifyM s OpenModule
forall s. MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' MooEnv
emptyMooEnv
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU = (Map ModuleName [ModuleWithSourceU s]
forall k a. Map k a
Map.empty, Map ModuleName [ModuleWithSourceU s]
forall k a. Map k a
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 :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
ci_msg ci :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci
| ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Bool
forall id rn. ComponentInclude id rn -> Bool
ci_implicit ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci = [Char] -> Doc
text "build-depends:" Doc -> Doc -> Doc
<+> Doc
pp_pn
| Bool
otherwise = [Char] -> Doc
text "mixins:" Doc -> Doc -> Doc
<+> Doc
pp_pn Doc -> Doc -> Doc
<+> IncludeRenaming -> Doc
forall a. Pretty a => a -> Doc
pretty (ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> IncludeRenaming
forall id rn. ComponentInclude id rn -> rn
ci_renaming ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci)
where
pn :: PackageName
pn = PackageIdentifier -> PackageName
pkgName (ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> PackageIdentifier
forall id rn. ComponentInclude id rn -> PackageIdentifier
ci_pkgid ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci)
pp_pn :: Doc
pp_pn =
case ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> ComponentName
forall id rn. ComponentInclude id rn -> ComponentName
ci_cname ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci of
CLibName LMainLibName -> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
CLibName (LSubLibName cn :: UnqualComponentName
cn) -> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn Doc -> Doc -> Doc
<<>> Doc
colon Doc -> Doc -> Doc
<<>> UnqualComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty UnqualComponentName
cn
cn :: ComponentName
cn -> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn Doc -> Doc -> Doc
<+> Doc -> Doc
parens (ComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty ComponentName
cn)
convertInclude
:: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM s (ModuleScopeU s,
Either (ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming) )
convertInclude :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
convertInclude ci :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci@(ComponentInclude {
ci_ann_id :: forall id rn. ComponentInclude id rn -> AnnotatedId id
ci_ann_id = AnnotatedId {
ann_id :: forall id. AnnotatedId id -> id
ann_id = (uid :: OpenUnitId
uid, ModuleShape provs :: OpenModuleSubst
provs reqs :: Set ModuleName
reqs),
ann_pid :: forall id. AnnotatedId id -> PackageIdentifier
ann_pid = PackageIdentifier
pid,
ann_cname :: forall id. AnnotatedId id -> ComponentName
ann_cname = ComponentName
compname
},
ci_renaming :: forall id rn. ComponentInclude id rn -> rn
ci_renaming = incl :: IncludeRenaming
incl@(IncludeRenaming prov_rns :: ModuleRenaming
prov_rns req_rns :: ModuleRenaming
req_rns),
ci_implicit :: forall id rn. ComponentInclude id rn -> Bool
ci_implicit = Bool
implicit
}) = Doc
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
forall s a. Doc -> UnifyM s a -> UnifyM s a
addErrContext ([Char] -> Doc
text "In" Doc -> Doc -> Doc
<+> ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
ci_msg ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci) (UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming)))
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
forall a b. (a -> b) -> a -> b
$ do
let pn :: PackageName
pn = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pid
the_source :: ModuleSource
the_source | Bool
implicit
= PackageName -> ComponentName -> ModuleSource
FromBuildDepends PackageName
pn ComponentName
compname
| Bool
otherwise
= PackageName -> ComponentName -> IncludeRenaming -> ModuleSource
FromMixins PackageName
pn ComponentName
compname IncludeRenaming
incl
source :: a -> WithSource a
source = ModuleSource -> a -> WithSource a
forall a. ModuleSource -> a -> WithSource a
WithSource ModuleSource
the_source
[(ModuleName, ModuleName)]
req_rename_list <-
case ModuleRenaming
req_rns of
DefaultRenaming -> [(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
HidingRenaming _ -> do
Doc -> UnifyM s ()
forall s. Doc -> UnifyM s ()
addErr (Doc -> UnifyM s ()) -> Doc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text "Unsupported syntax" Doc -> Doc -> Doc
<+>
Doc -> Doc
quotes ([Char] -> Doc
text "requires hiding (...)")
[(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
ModuleRenaming rns :: [(ModuleName, ModuleName)]
rns -> [(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ModuleName, ModuleName)]
rns
let req_rename_listmap :: Map ModuleName [ModuleName]
req_rename_listmap :: Map ModuleName [ModuleName]
req_rename_listmap =
([ModuleName] -> [ModuleName] -> [ModuleName])
-> [(ModuleName, [ModuleName])] -> Map ModuleName [ModuleName]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
(++) [ (ModuleName
k,[ModuleName
v]) | (k :: ModuleName
k,v :: ModuleName
v) <- [(ModuleName, ModuleName)]
req_rename_list ]
Map ModuleName ModuleName
req_rename <- Map ModuleName (UnifyM s ModuleName)
-> UnifyM s (Map ModuleName ModuleName)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Map ModuleName (UnifyM s ModuleName)
-> UnifyM s (Map ModuleName ModuleName))
-> ((ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> Map ModuleName (UnifyM s ModuleName))
-> (ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> UnifyM s (Map ModuleName ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> Map ModuleName [ModuleName]
-> Map ModuleName (UnifyM s ModuleName))
-> Map ModuleName [ModuleName]
-> (ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> Map ModuleName (UnifyM s ModuleName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> Map ModuleName [ModuleName]
-> Map ModuleName (UnifyM s ModuleName)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map ModuleName [ModuleName]
req_rename_listmap ((ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> UnifyM s (Map ModuleName ModuleName))
-> (ModuleName -> [ModuleName] -> UnifyM s ModuleName)
-> UnifyM s (Map ModuleName ModuleName)
forall a b. (a -> b) -> a -> b
$ \k :: ModuleName
k vs0 :: [ModuleName]
vs0 ->
case [ModuleName]
vs0 of
[] -> [Char] -> UnifyM s ModuleName
forall a. HasCallStack => [Char] -> a
error "req_rename"
[v :: ModuleName
v] -> ModuleName -> UnifyM s ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
v
v :: ModuleName
v:vs :: [ModuleName]
vs -> do Doc -> UnifyM s ()
forall s. Doc -> UnifyM s ()
addErr (Doc -> UnifyM s ()) -> Doc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
[Char] -> Doc
text "Conflicting renamings of requirement" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
k) Doc -> Doc -> Doc
$$
[Char] -> Doc
text "Renamed to: " Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((ModuleName -> Doc) -> [ModuleName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty (ModuleName
vModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:[ModuleName]
vs))
ModuleName -> UnifyM s ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
v
let req_rename_fn :: ModuleName -> ModuleName
req_rename_fn k :: ModuleName
k = case ModuleName -> Map ModuleName ModuleName -> Maybe ModuleName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
k Map ModuleName ModuleName
req_rename of
Nothing -> ModuleName
k
Just v :: ModuleName
v -> ModuleName
v
let req_subst :: OpenModuleSubst
req_subst = (ModuleName -> OpenModule)
-> Map ModuleName ModuleName -> OpenModuleSubst
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName -> OpenModule
OpenModuleVar Map ModuleName ModuleName
req_rename
UnitIdU s
uid_u <- OpenUnitId -> UnifyM s (UnitIdU s)
forall s. OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId (OpenModuleSubst -> OpenUnitId -> OpenUnitId
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
req_subst OpenUnitId
uid)
ModuleRequiresU s
reqs_u <- ModuleRequires -> UnifyM s (ModuleRequiresU s)
forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires (ModuleRequires -> UnifyM s (ModuleRequiresU s))
-> ([(ModuleName, [ModuleWithSource])] -> ModuleRequires)
-> [(ModuleName, [ModuleWithSource])]
-> UnifyM s (ModuleRequiresU s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ModuleName, [ModuleWithSource])] -> ModuleRequires
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ModuleName, [ModuleWithSource])]
-> UnifyM s (ModuleRequiresU s))
-> [(ModuleName, [ModuleWithSource])]
-> UnifyM s (ModuleRequiresU s)
forall a b. (a -> b) -> a -> b
$
[ (ModuleName
k, [OpenModule -> ModuleWithSource
forall a. a -> WithSource a
source (ModuleName -> OpenModule
OpenModuleVar ModuleName
k)])
| ModuleName
k <- (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> ModuleName
req_rename_fn (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
reqs)
]
let leftover :: Set ModuleName
leftover = Map ModuleName ModuleName -> Set ModuleName
forall k a. Map k a -> Set k
Map.keysSet Map ModuleName ModuleName
req_rename Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ModuleName
reqs
Bool -> UnifyM s () -> UnifyM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
leftover) (UnifyM s () -> UnifyM s ()) -> UnifyM s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
Doc -> UnifyM s ()
forall s. Doc -> UnifyM s ()
addErr (Doc -> UnifyM s ()) -> Doc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
Doc -> UnitIdUnique -> Doc -> Doc
hang ([Char] -> Doc
text "The" Doc -> Doc -> Doc
<+> [Char] -> Doc
text (ComponentName -> [Char]
showComponentName ComponentName
compname) Doc -> Doc -> Doc
<+>
[Char] -> Doc
text "from package" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (PackageIdentifier -> Doc
forall a. Pretty a => a -> Doc
pretty PackageIdentifier
pid)
Doc -> Doc -> Doc
<+> [Char] -> Doc
text "does not require:") 4
([Doc] -> Doc
vcat ((ModuleName -> Doc) -> [ModuleName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
leftover)))
(pre_prov_scope :: [(ModuleName, OpenModule)]
pre_prov_scope, prov_rns' :: ModuleRenaming
prov_rns') <-
case ModuleRenaming
prov_rns of
DefaultRenaming -> ([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenModuleSubst -> [(ModuleName, OpenModule)]
forall k a. Map k a -> [(k, a)]
Map.toList OpenModuleSubst
provs, ModuleRenaming
prov_rns)
HidingRenaming hides :: [ModuleName]
hides ->
let hides_set :: Set ModuleName
hides_set = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList [ModuleName]
hides
in let r :: [(ModuleName, OpenModule)]
r = [ (ModuleName
k,OpenModule
v)
| (k :: ModuleName
k,v :: OpenModule
v) <- OpenModuleSubst -> [(ModuleName, OpenModule)]
forall k a. Map k a -> [(k, a)]
Map.toList OpenModuleSubst
provs
, Bool -> Bool
not (ModuleName
k ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ModuleName
hides_set) ]
in ([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ModuleName, OpenModule)]
r, [(ModuleName, ModuleName)] -> ModuleRenaming
ModuleRenaming (((ModuleName, OpenModule) -> (ModuleName, ModuleName))
-> [(ModuleName, OpenModule)] -> [(ModuleName, ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map ((\x :: ModuleName
x -> (ModuleName
x,ModuleName
x))(ModuleName -> (ModuleName, ModuleName))
-> ((ModuleName, OpenModule) -> ModuleName)
-> (ModuleName, OpenModule)
-> (ModuleName, ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ModuleName, OpenModule) -> ModuleName
forall a b. (a, b) -> a
fst) [(ModuleName, OpenModule)]
r))
ModuleRenaming rns :: [(ModuleName, ModuleName)]
rns -> do
[(ModuleName, OpenModule)]
r <- [UnifyM s (ModuleName, OpenModule)]
-> UnifyM s [(ModuleName, OpenModule)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ case ModuleName -> OpenModuleSubst -> Maybe OpenModule
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
from OpenModuleSubst
provs of
Just m :: OpenModule
m -> (ModuleName, OpenModule) -> UnifyM s (ModuleName, OpenModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
to, OpenModule
m)
Nothing -> Doc -> UnifyM s (ModuleName, OpenModule)
forall s a. Doc -> UnifyM s a
failWith (Doc -> UnifyM s (ModuleName, OpenModule))
-> Doc -> UnifyM s (ModuleName, OpenModule)
forall a b. (a -> b) -> a -> b
$
[Char] -> Doc
text "Package" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (PackageIdentifier -> Doc
forall a. Pretty a => a -> Doc
pretty PackageIdentifier
pid) Doc -> Doc -> Doc
<+>
[Char] -> Doc
text "does not expose the module" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
from)
| (from :: ModuleName
from, to :: ModuleName
to) <- [(ModuleName, ModuleName)]
rns ]
([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ModuleName, OpenModule)]
r, ModuleRenaming
prov_rns)
let prov_scope :: ModuleRequires
prov_scope = OpenModuleSubst -> ModuleRequires -> ModuleRequires
forall a. ModSubst a => OpenModuleSubst -> a -> a
modSubst OpenModuleSubst
req_subst
(ModuleRequires -> ModuleRequires)
-> ModuleRequires -> ModuleRequires
forall a b. (a -> b) -> a -> b
$ ([ModuleWithSource] -> [ModuleWithSource] -> [ModuleWithSource])
-> [(ModuleName, [ModuleWithSource])] -> ModuleRequires
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [ModuleWithSource] -> [ModuleWithSource] -> [ModuleWithSource]
forall a. [a] -> [a] -> [a]
(++)
[ (ModuleName
k, [OpenModule -> ModuleWithSource
forall a. a -> WithSource a
source OpenModule
v])
| (k :: ModuleName
k, v :: OpenModule
v) <- [(ModuleName, OpenModule)]
pre_prov_scope ]
ModuleRequiresU s
provs_u <- ModuleRequires -> UnifyM s (ModuleRequiresU s)
forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleProvides ModuleRequires
prov_scope
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
-> UnifyM
s
(ModuleScopeU s,
Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming))
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModuleRequiresU s
provs_u, ModuleRequiresU s
reqs_u),
(if OpenModuleSubst -> Bool
forall k a. Map k a -> Bool
Map.null OpenModuleSubst
provs Bool -> Bool -> Bool
&& Bool -> Bool
not (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
reqs)
then ComponentInclude (UnitIdU s) ModuleRenaming
-> Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming)
forall a b. b -> Either a b
Right
else ComponentInclude (UnitIdU s) ModuleRenaming
-> Either
(ComponentInclude (UnitIdU s) ModuleRenaming)
(ComponentInclude (UnitIdU s) ModuleRenaming)
forall a b. a -> Either a b
Left) (ComponentInclude :: forall id rn.
AnnotatedId id -> rn -> Bool -> ComponentInclude id rn
ComponentInclude {
ci_ann_id :: AnnotatedId (UnitIdU s)
ci_ann_id = AnnotatedId :: forall id.
PackageIdentifier -> ComponentName -> id -> AnnotatedId id
AnnotatedId {
ann_id :: UnitIdU s
ann_id = UnitIdU s
uid_u,
ann_pid :: PackageIdentifier
ann_pid = PackageIdentifier
pid,
ann_cname :: ComponentName
ann_cname = ComponentName
compname
},
ci_renaming :: ModuleRenaming
ci_renaming = ModuleRenaming
prov_rns',
ci_implicit :: Bool
ci_implicit = ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Bool
forall id rn. ComponentInclude id rn -> Bool
ci_implicit ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
ci
}))
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU (provs_u :: ModuleProvidesU s
provs_u, reqs_u :: ModuleProvidesU s
reqs_u) = do
ModuleRequires
provs <- ModuleProvidesU s -> UnifyM s ModuleRequires
forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleProvidesU ModuleProvidesU s
provs_u
ModuleRequires
reqs <- ModuleProvidesU s -> UnifyM s ModuleRequires
forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleRequiresU ModuleProvidesU s
reqs_u
ModuleScope -> UnifyM s ModuleScope
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleRequires -> ModuleRequires -> ModuleScope
ModuleScope ModuleRequires
provs ModuleRequires
reqs)
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
convertModuleProvides :: ModuleRequires -> UnifyM s (ModuleProvidesU s)
convertModuleProvides = ([ModuleWithSource] -> UnifyM s [WithSource (ModuleU s)])
-> ModuleRequires -> UnifyM s (ModuleProvidesU s)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ((ModuleWithSource -> UnifyM s (WithSource (ModuleU s)))
-> [ModuleWithSource] -> UnifyM s [WithSource (ModuleU s)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((OpenModule -> UnifyM s (ModuleU s))
-> ModuleWithSource -> UnifyM s (WithSource (ModuleU s))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule))
convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides
convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleProvidesU = ([WithSource (ModuleU s)] -> UnifyM s [ModuleWithSource])
-> ModuleProvidesU s -> UnifyM s ModuleRequires
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ((WithSource (ModuleU s) -> UnifyM s ModuleWithSource)
-> [WithSource (ModuleU s)] -> UnifyM s [ModuleWithSource]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ModuleU s -> UnifyM s OpenModule)
-> WithSource (ModuleU s) -> UnifyM s ModuleWithSource
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU))
convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires = ModuleRequires -> UnifyM s (ModuleRequiresU s)
forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleProvides
convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires
convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires
convertModuleRequiresU = ModuleRequiresU s -> UnifyM s ModuleRequires
forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleProvidesU