{-# 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 Distribution.Compat.Prelude hiding (mod)
import Prelude ()

import Distribution.Backpack
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ModSubst
import Distribution.Backpack.ModuleScope
import Distribution.Backpack.ModuleShape

import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Types.AnnotatedId
import Distribution.Types.ComponentInclude
import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.Verbosity

import Control.Monad.ST
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.STRef
import qualified Data.Set as Set
import Data.Traversable
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
  { 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

-- | The unification monad, this monad encapsulates imperative
-- unification.
newtype UnifyM s a = UnifyM {forall s a. UnifyM s a -> UnifEnv s -> ST s (Maybe a)
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 :: forall a.
Verbosity
-> ComponentId
-> FullDb
-> (forall s. UnifyM s a)
-> Either [Doc] a
runUnifyM Verbosity
verbosity ComponentId
self_cid FullDb
db 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 Int
i <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
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
          { unify_uniq :: STRef s Int
unify_uniq = STRef s Int
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 a
x | [ErrMsg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
final_errs -> Either [Doc] a -> ST s (Either [Doc] a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either [Doc] a
forall a b. b -> Either a b
Right a
x)
      Maybe a
_ -> Either [Doc] a -> ST s (Either [Doc] a)
forall a. a -> ST s 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)))

-- 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
  { forall s. UnifEnv s -> UnifRef s Int
unify_uniq :: UnifRef s UnitIdUnique
  -- ^ A supply of unique integers to label 'UnitIdU'
  -- cells.  This is used to determine loops in unit
  -- identifiers (which can happen with mutual recursion.)
  , forall s. UnifEnv s -> UnifRef s (Map ModuleName (ModuleU s))
unify_reqs :: UnifRef s (Map ModuleName (ModuleU s))
  -- ^ 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.
  , forall s. UnifEnv s -> ComponentId
unify_self_cid :: ComponentId
  -- ^ 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.
  , forall s. UnifEnv s -> Verbosity
unify_verbosity :: Verbosity
  -- ^ How verbose the error message should be
  , forall s. UnifEnv s -> [Doc]
unify_ctx :: [ErrCtx s]
  -- ^ The error reporting context
  , forall s. UnifEnv s -> FullDb
unify_db :: FullDb
  -- ^ The package index for expanding unit identifiers
  , forall s. UnifEnv s -> UnifRef s [ErrMsg]
unify_errs :: UnifRef s [ErrMsg]
  -- ^ Accumulated errors
  }

instance Functor (UnifyM s) where
  fmap :: forall a b. (a -> b) -> UnifyM s a -> UnifyM s b
fmap a -> b
f (UnifyM 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 a b. (a -> b) -> (UnifEnv s -> a) -> UnifEnv s -> 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 a b. (a -> b) -> ST s a -> ST s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall a b. (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 :: forall a. 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 a. a -> UnifEnv s -> 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 a. a -> ST s 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 a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  UnifyM UnifEnv s -> ST s (Maybe (a -> b))
f <*> :: forall a b. UnifyM s (a -> b) -> UnifyM s a -> UnifyM s b
<*> UnifyM 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
$ \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
      Maybe (a -> b)
Nothing -> Maybe b -> ST s (Maybe b)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
      Just a -> b
f'' -> do
        Maybe a
x' <- UnifEnv s -> ST s (Maybe a)
x UnifEnv s
r
        case Maybe a
x' of
          Maybe a
Nothing -> Maybe b -> ST s (Maybe b)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
          Just a
x'' -> Maybe b -> ST s (Maybe b)
forall a. a -> ST s a
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 :: forall a. a -> UnifyM s a
return = a -> UnifyM s a
forall a. a -> UnifyM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  UnifyM UnifEnv s -> ST s (Maybe a)
m >>= :: forall a b. UnifyM s a -> (a -> UnifyM s b) -> UnifyM s b
>>= 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
$ \UnifEnv s
r -> do
    Maybe a
x <- UnifEnv s -> ST s (Maybe a)
m UnifEnv s
r
    case Maybe a
x of
      Maybe a
Nothing -> Maybe b -> ST s (Maybe b)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
      Just 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

-- | Lift a computation from 'ST' monad to 'UnifyM' monad.
-- Internal use only.
liftST :: ST s a -> UnifyM s a
liftST :: forall s a. ST s a -> UnifyM s a
liftST 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
$ \UnifEnv s
_ -> (a -> Maybe a) -> ST s a -> ST s (Maybe a)
forall a b. (a -> b) -> ST s a -> ST s b
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 :: forall s. Doc -> UnifyM s ()
addErr Doc
msg = do
  UnifEnv s
env <- UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
  let err :: ErrMsg
err =
        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) (\[ErrMsg]
errs -> ErrMsg
err ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
: [ErrMsg]
errs)

failWith :: MsgDoc -> UnifyM s a
failWith :: forall s a. Doc -> UnifyM s a
failWith 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 :: forall s a. 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
$ \UnifEnv s
_ -> Maybe a -> ST s (Maybe a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

failIfErrs :: UnifyM s ()
failIfErrs :: forall s. 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 a. [a] -> 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 :: forall s a. UnifyM s a -> UnifyM s (Maybe a)
tryM 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
    ( \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 a. a -> ST s 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)
    )

{-
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 :: forall s a. 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

-- | Imperatively write a 'UnifRef'.
writeUnifRef :: UnifRef s a -> a -> UnifyM s ()
writeUnifRef :: forall s a. UnifRef s a -> a -> UnifyM s ()
writeUnifRef 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

-- | Get the current unification environment.
getUnifEnv :: UnifyM s (UnifEnv s)
getUnifEnv :: forall s. 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
$ \UnifEnv s
r -> Maybe (UnifEnv s) -> ST s (Maybe (UnifEnv s))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnifEnv s -> Maybe (UnifEnv s)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return UnifEnv s
r)

-- | Add a fixed message to the error context.
addErrContext :: Doc -> UnifyM s a -> UnifyM s a
addErrContext :: forall s a. Doc -> UnifyM s a -> UnifyM s a
addErrContext Doc
ctx 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

-- | Add a message to the error context.  It may make monadic queries.
addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
addErrContextM :: forall s a. Doc -> UnifyM s a -> UnifyM s a
addErrContextM Doc
ctx 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
$ \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 = 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 :: forall s. MuEnv s -> UnitIdU s -> MuEnv s
extendMuEnv (IntMap (UnitIdU s)
m, Int
i) UnitIdU s
x =
  (Int -> UnitIdU s -> IntMap (UnitIdU s) -> IntMap (UnitIdU s)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) UnitIdU s
x IntMap (UnitIdU s)
m, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 :: forall s. MuEnv s
emptyMuEnv = (IntMap (UnitIdU s)
forall a. IntMap a
IntMap.empty, -Int
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' :: forall s. MuEnv s -> OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId' MuEnv s
_ (DefiniteUnitId 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' MuEnv s
stk (IndefFullUnitId ComponentId
cid OpenModuleSubst
insts) = do
  UnifRef s Int
fs <- (UnifEnv s -> UnifRef s Int)
-> UnifyM s (UnifEnv s) -> UnifyM s (UnifRef s Int)
forall a b. (a -> b) -> UnifyM s a -> UnifyM s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnifEnv s -> UnifRef s Int
forall s. UnifEnv s -> UnifRef s Int
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 [Char]
"convertUnitId") -- tie the knot later
  Map ModuleName (ModuleU s)
insts_u <- OpenModuleSubst
-> (OpenModule -> UnifyM s (ModuleU s))
-> UnifyM s (Map ModuleName (ModuleU s))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for 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)
  Int
u <- UnifRef s Int -> UnifyM s Int
forall s a. UnifRef s a -> UnifyM s a
readUnifRef UnifRef s Int
fs
  UnifRef s Int -> Int -> UnifyM s ()
forall s a. UnifRef s a -> a -> UnifyM s ()
writeUnifRef UnifRef s Int
fs (Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 (Int -> ComponentId -> Map ModuleName (ModuleU s) -> UnitIdU' s
forall s.
Int -> ComponentId -> Map ModuleName (ModuleU s) -> UnitIdU' s
UnitIdU Int
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 a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return UnitIdU s
y

-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)

convertModule'
  :: MuEnv s
  -> OpenModule
  -> UnifyM s (ModuleU s)
convertModule' :: forall s. MuEnv s -> OpenModule -> UnifyM s (ModuleU s)
convertModule' MuEnv s
_stk (OpenModuleVar 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 a b. (a -> b) -> UnifyM s a -> UnifyM s b
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
    Maybe (ModuleU s)
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 a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleU s
mod
    Just ModuleU s
mod -> ModuleU s -> UnifyM s (ModuleU s)
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleU s
mod
convertModule' MuEnv s
stk (OpenModule OpenUnitId
uid 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 :: forall s. 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 :: forall s. 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

-----------------------------------------------------------------------
-- 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 :: forall s. OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst = (OpenModule -> UnifyM s (ModuleU s))
-> OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule

-- | Conversion of 'ModuleSubstU' to 'ModuleSubst'
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU :: forall s. ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU = (ModuleU s -> UnifyM s OpenModule)
-> Map ModuleName (ModuleU s) -> UnifyM s OpenModuleSubst
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
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 :: MooEnv
emptyMooEnv = (IntMap Int
forall a. IntMap a
IntMap.empty, -Int
1)

extendMooEnv :: MooEnv -> UnitIdUnique -> MooEnv
extendMooEnv :: MooEnv -> Int -> MooEnv
extendMooEnv (IntMap Int
m, Int
i) Int
k = (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IntMap Int
m, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int
lookupMooEnv :: MooEnv -> Int -> Maybe Int
lookupMooEnv (IntMap Int
m, Int
i) Int
k =
  case Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap Int
m of
    Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
    Just Int
v -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
v) -- de Bruijn indexize

-- The workhorse functions

-- | Returns `OpenUnitId` if there is no a mutually recursive unit.
-- | Otherwise returns a list of signatures instantiated by given `UnitIdU`.
convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU' :: forall s. MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU' MooEnv
stk UnitIdU s
uid_u Doc
required_mod_name = 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 DefUnitId
uid -> OpenUnitId -> UnifyM s OpenUnitId
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenUnitId -> UnifyM s OpenUnitId)
-> OpenUnitId -> UnifyM s OpenUnitId
forall a b. (a -> b) -> a -> b
$ DefUnitId -> OpenUnitId
DefiniteUnitId DefUnitId
uid
    UnitIdU Int
u ComponentId
cid Map ModuleName (ModuleU s)
insts_u ->
      case MooEnv -> Int -> Maybe Int
lookupMooEnv MooEnv
stk Int
u of
        Just Int
_ ->
          let mod_names :: [ModuleName]
mod_names = Map ModuleName (ModuleU s) -> [ModuleName]
forall k a. Map k a -> [k]
Map.keys Map ModuleName (ModuleU s)
insts_u
           in Doc -> [ModuleName] -> UnifyM s OpenUnitId
forall s a. Doc -> [ModuleName] -> UnifyM s a
failWithMutuallyRecursiveUnitsError Doc
required_mod_name [ModuleName]
mod_names
        Maybe Int
Nothing -> do
          OpenModuleSubst
insts <- Map ModuleName (ModuleU s)
-> (ModuleU s -> UnifyM s OpenModule) -> UnifyM s OpenModuleSubst
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for 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 -> Int -> MooEnv
extendMooEnv MooEnv
stk Int
u)
          OpenUnitId -> UnifyM s OpenUnitId
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenUnitId -> UnifyM s OpenUnitId)
-> OpenUnitId -> UnifyM s OpenUnitId
forall a b. (a -> b) -> a -> b
$ ComponentId -> OpenModuleSubst -> OpenUnitId
IndefFullUnitId ComponentId
cid OpenModuleSubst
insts

convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' :: forall s. MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' MooEnv
stk 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 ModuleName
mod_name -> OpenModule -> UnifyM s OpenModule
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> OpenModule
OpenModuleVar ModuleName
mod_name)
    ModuleU UnitIdU s
uid_u ModuleName
mod_name -> do
      OpenUnitId
uid <- MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
forall s. MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU' MooEnv
stk UnitIdU s
uid_u (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
mod_name)
      OpenModule -> UnifyM s OpenModule
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenUnitId -> ModuleName -> OpenModule
OpenModule OpenUnitId
uid ModuleName
mod_name)

failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a
failWithMutuallyRecursiveUnitsError :: forall s a. Doc -> [ModuleName] -> UnifyM s a
failWithMutuallyRecursiveUnitsError Doc
required_mod_name [ModuleName]
mod_names =
  let sigsList :: Doc
sigsList = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate ([Char] -> Doc
text [Char]
", ") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Doc) -> [ModuleName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
quotes (Doc -> Doc) -> (ModuleName -> Doc) -> ModuleName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty) [ModuleName]
mod_names
   in Doc -> UnifyM s a
forall s a. Doc -> UnifyM s a
failWith (Doc -> UnifyM s a) -> Doc -> UnifyM s a
forall a b. (a -> b) -> a -> b
$
        [Char] -> Doc
text [Char]
"Cannot instantiate requirement"
          Doc -> Doc -> Doc
<+> Doc -> Doc
quotes Doc
required_mod_name
          Doc -> Doc -> Doc
$$ [Char] -> Doc
text [Char]
"Ensure \"build-depends:\" doesn't include any library with signatures:"
          Doc -> Doc -> Doc
<+> Doc
sigsList
          Doc -> Doc -> Doc
$$ [Char] -> Doc
text [Char]
"as this creates a cyclic dependency, which GHC does not support."

-- Helper functions

convertUnitIdU :: UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU :: forall s. UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU = MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
forall s. MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU' MooEnv
emptyMooEnv

convertModuleU :: ModuleU s -> UnifyM s OpenModule
convertModuleU :: forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU = MooEnv -> ModuleU s -> UnifyM s OpenModule
forall s. MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' MooEnv
emptyMooEnv

-- | An empty 'ModuleScopeU'.
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU :: forall s. 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)

-- | 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 :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc
ci_msg 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 [Char]
"build-depends:" Doc -> Doc -> Doc
<+> Doc
pp_pn
  | Bool
otherwise = [Char] -> Doc
text [Char]
"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 LibraryName
LMainLibName -> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
        CLibName (LSubLibName 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
        -- Shouldn't happen
        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)

-- | 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 :: forall s.
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 = (OpenUnitId
uid, ModuleShape OpenModuleSubst
provs 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 ModuleRenaming
prov_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 [Char]
"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

    -- 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.

    [(ModuleName, ModuleName)]
req_rename_list <-
      case ModuleRenaming
req_rns of
        ModuleRenaming
DefaultRenaming -> [(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        HidingRenaming [ModuleName]
_ -> do
          -- Not valid here for requires!
          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 [Char]
"Unsupported syntax"
              Doc -> Doc -> Doc
<+> Doc -> Doc
quotes ([Char] -> Doc
text [Char]
"requires hiding (...)")
          [(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        ModuleRenaming [(ModuleName, ModuleName)]
rns -> [(ModuleName, ModuleName)] -> UnifyM s [(ModuleName, ModuleName)]
forall a. a -> UnifyM s a
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]) | (ModuleName
k, 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)
forall (f :: * -> *) a.
Applicative f =>
Map ModuleName (f a) -> f (Map ModuleName 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
$ \ModuleName
k [ModuleName]
vs0 ->
      case [ModuleName]
vs0 of
        [] -> [Char] -> UnifyM s ModuleName
forall a. HasCallStack => [Char] -> a
error [Char]
"req_rename"
        [ModuleName
v] -> ModuleName -> UnifyM s ModuleName
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
v
        ModuleName
v : [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 [Char]
"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 [Char]
"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
v ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
vs))
          ModuleName -> UnifyM s ModuleName
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
v

    let req_rename_fn :: ModuleName -> ModuleName
req_rename_fn 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
          Maybe ModuleName
Nothing -> ModuleName
k
          Just ModuleName
v -> ModuleName
v

    -- Requirement substitution.
    --
    --      A -> X      ==>     A -> <X>
    let req_subst :: OpenModuleSubst
req_subst = (ModuleName -> OpenModule)
-> Map ModuleName ModuleName -> OpenModuleSubst
forall a b. (a -> b) -> Map ModuleName a -> Map ModuleName b
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)

    -- 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>
    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)
        ]

    -- Report errors if there were unused renamings
    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 -> Int -> Doc -> Doc
hang
          ( [Char] -> Doc
text [Char]
"The"
              Doc -> Doc -> Doc
<+> [Char] -> Doc
text (ComponentName -> [Char]
showComponentName ComponentName
compname)
              Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"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 [Char]
"does not require:"
          )
          Int
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)))

    -- 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.
    ([(ModuleName, OpenModule)]
pre_prov_scope, ModuleRenaming
prov_rns') <-
      case ModuleRenaming
prov_rns of
        ModuleRenaming
DefaultRenaming -> ([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall a. a -> UnifyM s a
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 [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)
                    | (ModuleName
k, 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 -- GHC doesn't understand hiding, so expand it out!
                  ([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall a. a -> UnifyM s a
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 ((\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 [(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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 OpenModule
m -> (ModuleName, OpenModule) -> UnifyM s (ModuleName, OpenModule)
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
to, OpenModule
m)
                Maybe OpenModule
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 [Char]
"Package"
                      Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (PackageIdentifier -> Doc
forall a. Pretty a => a -> Doc
pretty PackageIdentifier
pid)
                      Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"does not expose the module"
                      Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
from)
              | (ModuleName
from, ModuleName
to) <- [(ModuleName, ModuleName)]
rns
              ]
          ([(ModuleName, OpenModule)], ModuleRenaming)
-> UnifyM s ([(ModuleName, OpenModule)], ModuleRenaming)
forall a. a -> UnifyM s a
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])
              | (ModuleName
k, 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

    -- TODO: Assert that provs_u is empty if provs was empty
    (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. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( (ModuleRequiresU s
provs_u, ModuleRequiresU s
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 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 -- is sig
            else ComponentInclude (UnitIdU s) ModuleRenaming
-> Either
     (ComponentInclude (UnitIdU s) ModuleRenaming)
     (ComponentInclude (UnitIdU s) ModuleRenaming)
forall a b. a -> Either a b
Left
        )
          ( ComponentInclude
              { ci_ann_id :: AnnotatedId (UnitIdU s)
ci_ann_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
              }
          )
      )

-- | Convert a 'ModuleScopeU' to a 'ModuleScope'.
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU :: forall s. ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU (ModuleProvidesU s
provs_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
  -- TODO: Test that the requirements are still free. If they
  -- are not, they got unified, and that's dodgy at best.
  ModuleScope -> UnifyM s ModuleScope
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleRequires -> ModuleRequires -> ModuleScope
ModuleScope ModuleRequires
provs ModuleRequires
reqs)

-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
convertModuleProvides :: forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleProvides = ([ModuleWithSource] -> UnifyM s [ModuleWithSourceU s])
-> ModuleRequires
-> UnifyM s (Map ModuleName [ModuleWithSourceU s])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse ((ModuleWithSource -> UnifyM s (ModuleWithSourceU s))
-> [ModuleWithSource] -> UnifyM s [ModuleWithSourceU s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((OpenModule -> UnifyM s (ModuleU s))
-> ModuleWithSource -> UnifyM s (ModuleWithSourceU s)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithSource a -> f (WithSource b)
traverse OpenModule -> UnifyM s (ModuleU s)
forall s. OpenModule -> UnifyM s (ModuleU s)
convertModule))

-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'
convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides
convertModuleProvidesU :: forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleProvidesU = ([ModuleWithSourceU s] -> UnifyM s [ModuleWithSource])
-> Map ModuleName [ModuleWithSourceU s] -> UnifyM s ModuleRequires
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map ModuleName a -> f (Map ModuleName b)
traverse ((ModuleWithSourceU s -> UnifyM s ModuleWithSource)
-> [ModuleWithSourceU s] -> UnifyM s [ModuleWithSource]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ModuleU s -> UnifyM s OpenModule)
-> ModuleWithSourceU s -> UnifyM s ModuleWithSource
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithSource a -> f (WithSource b)
traverse ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU))

convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires :: forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires = ModuleRequires -> UnifyM s (ModuleProvidesU s)
forall s. ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleProvides

convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires
convertModuleRequiresU :: forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleRequiresU = ModuleProvidesU s -> UnifyM s ModuleRequires
forall s. ModuleProvidesU s -> UnifyM s ModuleRequires
convertModuleProvidesU