{-# LANGUAGE NondecreasingIndentation #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.MixLink (
    mixLink,
) where

import Prelude ()
import Distribution.Compat.Prelude hiding (mod)

import Distribution.Backpack
import Distribution.Backpack.UnifyM
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ModuleScope

import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.ModuleName
import Distribution.Pretty
import Distribution.Types.ComponentId

import Text.PrettyPrint
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Foldable as F

-----------------------------------------------------------------------
-- Linking

-- | Given to scopes of provisions and requirements, link them together.
mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink scopes :: [ModuleScopeU s]
scopes = do
    let provs :: Map ModuleName [ModuleWithSourceU s]
provs = ([ModuleWithSourceU s]
 -> [ModuleWithSourceU s] -> [ModuleWithSourceU s])
-> [Map ModuleName [ModuleWithSourceU s]]
-> Map ModuleName [ModuleWithSourceU s]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [ModuleWithSourceU s]
-> [ModuleWithSourceU s] -> [ModuleWithSourceU s]
forall a. [a] -> [a] -> [a]
(++) ((ModuleScopeU s -> Map ModuleName [ModuleWithSourceU s])
-> [ModuleScopeU s] -> [Map ModuleName [ModuleWithSourceU s]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleScopeU s -> Map ModuleName [ModuleWithSourceU s]
forall a b. (a, b) -> a
fst [ModuleScopeU s]
scopes)
        -- Invariant: any identically named holes refer to same mutable cell
        reqs :: Map ModuleName [ModuleWithSourceU s]
reqs  = ([ModuleWithSourceU s]
 -> [ModuleWithSourceU s] -> [ModuleWithSourceU s])
-> [Map ModuleName [ModuleWithSourceU s]]
-> Map ModuleName [ModuleWithSourceU s]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [ModuleWithSourceU s]
-> [ModuleWithSourceU s] -> [ModuleWithSourceU s]
forall a. [a] -> [a] -> [a]
(++) ((ModuleScopeU s -> Map ModuleName [ModuleWithSourceU s])
-> [ModuleScopeU s] -> [Map ModuleName [ModuleWithSourceU s]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleScopeU s -> Map ModuleName [ModuleWithSourceU s]
forall a b. (a, b) -> b
snd [ModuleScopeU s]
scopes)
        filled :: Map ModuleName (UnifyM s [ModuleWithSourceU s])
filled = (ModuleName
 -> [ModuleWithSourceU s]
 -> [ModuleWithSourceU s]
 -> UnifyM s [ModuleWithSourceU s])
-> Map ModuleName [ModuleWithSourceU s]
-> Map ModuleName [ModuleWithSourceU s]
-> Map ModuleName (UnifyM s [ModuleWithSourceU s])
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWithKey ModuleName
-> [ModuleWithSourceU s]
-> [ModuleWithSourceU s]
-> UnifyM s [ModuleWithSourceU s]
forall s.
ModuleName
-> [ModuleWithSourceU s]
-> [ModuleWithSourceU s]
-> UnifyM s [ModuleWithSourceU s]
linkProvision Map ModuleName [ModuleWithSourceU s]
provs Map ModuleName [ModuleWithSourceU s]
reqs
    Map ModuleName (UnifyM s [ModuleWithSourceU s]) -> UnifyM s ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
F.sequenceA_ Map ModuleName (UnifyM s [ModuleWithSourceU s])
filled
    let remaining :: Map ModuleName [ModuleWithSourceU s]
remaining = Map ModuleName [ModuleWithSourceU s]
-> Map ModuleName (UnifyM s [ModuleWithSourceU s])
-> Map ModuleName [ModuleWithSourceU s]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map ModuleName [ModuleWithSourceU s]
reqs Map ModuleName (UnifyM s [ModuleWithSourceU s])
filled
    ModuleScopeU s -> UnifyM s (ModuleScopeU s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ModuleName [ModuleWithSourceU s]
provs, Map ModuleName [ModuleWithSourceU s]
remaining)

-- | Link a list of possibly provided modules to a single
-- requirement.  This applies a side-condition that all
-- of the provided modules at the same name are *actually*
-- the same module.
linkProvision :: ModuleName
              -> [ModuleWithSourceU s] -- provs
              -> [ModuleWithSourceU s] -- reqs
              -> UnifyM s [ModuleWithSourceU s]
linkProvision :: ModuleName
-> [ModuleWithSourceU s]
-> [ModuleWithSourceU s]
-> UnifyM s [ModuleWithSourceU s]
linkProvision mod_name :: ModuleName
mod_name ret :: [ModuleWithSourceU s]
ret@(prov :: ModuleWithSourceU s
prov:provs :: [ModuleWithSourceU s]
provs) (req :: ModuleWithSourceU s
req:reqs :: [ModuleWithSourceU s]
reqs) = do
    -- TODO: coalesce all the non-unifying modules together
    [ModuleWithSourceU s]
-> (ModuleWithSourceU s -> UnifyM s ()) -> UnifyM s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ModuleWithSourceU s]
provs ((ModuleWithSourceU s -> UnifyM s ()) -> UnifyM s ())
-> (ModuleWithSourceU s -> UnifyM s ()) -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ \prov' :: ModuleWithSourceU s
prov' -> do
        -- Careful: read it out BEFORE unifying, because the
        -- unification algorithm preemptively unifies modules
        OpenModule
mod  <- ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU (ModuleWithSourceU s -> ModuleU s
forall a. WithSource a -> a
unWithSource ModuleWithSourceU s
prov)
        OpenModule
mod' <- ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU (ModuleWithSourceU s -> ModuleU s
forall a. WithSource a -> a
unWithSource ModuleWithSourceU s
prov')
        Maybe ()
r <- ModuleWithSourceU s -> ModuleWithSourceU s -> UnifyM s (Maybe ())
forall s.
WithSource (ModuleU s)
-> WithSource (ModuleU s) -> UnifyM s (Maybe ())
unify ModuleWithSourceU s
prov ModuleWithSourceU s
prov'
        case Maybe ()
r of
            Just () -> () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Nothing -> do
                MsgDoc -> UnifyM s ()
forall s. MsgDoc -> UnifyM s ()
addErr (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
                  String -> MsgDoc
text "Ambiguous module" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name) MsgDoc -> MsgDoc -> MsgDoc
$$
                  String -> MsgDoc
text "It could refer to" MsgDoc -> MsgDoc -> MsgDoc
<+>
                    ( String -> MsgDoc
text "  " MsgDoc -> MsgDoc -> MsgDoc
<+> (MsgDoc -> MsgDoc
quotes (OpenModule -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty OpenModule
mod)  MsgDoc -> MsgDoc -> MsgDoc
$$ ModuleSource -> MsgDoc
in_scope_by (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
prov)) MsgDoc -> MsgDoc -> MsgDoc
$$
                      String -> MsgDoc
text "or" MsgDoc -> MsgDoc -> MsgDoc
<+> (MsgDoc -> MsgDoc
quotes (OpenModule -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty OpenModule
mod') MsgDoc -> MsgDoc -> MsgDoc
$$ ModuleSource -> MsgDoc
in_scope_by (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
prov')) ) MsgDoc -> MsgDoc -> MsgDoc
$$
                  MsgDoc
link_doc
    OpenModule
mod <- ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU (ModuleWithSourceU s -> ModuleU s
forall a. WithSource a -> a
unWithSource ModuleWithSourceU s
prov)
    OpenModule
req_mod <- ModuleU s -> UnifyM s OpenModule
forall s. ModuleU s -> UnifyM s OpenModule
convertModuleU (ModuleWithSourceU s -> ModuleU s
forall a. WithSource a -> a
unWithSource ModuleWithSourceU s
req)
    ComponentId
self_cid <- (UnifEnv s -> ComponentId)
-> UnifyM s (UnifEnv s) -> UnifyM s ComponentId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnifEnv s -> ComponentId
forall s. UnifEnv s -> ComponentId
unify_self_cid UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
    case OpenModule
mod of
      OpenModule (IndefFullUnitId cid :: ComponentId
cid _) _
        | ComponentId
cid ComponentId -> ComponentId -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentId
self_cid -> MsgDoc -> UnifyM s ()
forall s. MsgDoc -> UnifyM s ()
addErr (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
            String -> MsgDoc
text "Cannot instantiate requirement" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name) MsgDoc -> MsgDoc -> MsgDoc
<+>
                ModuleSource -> MsgDoc
in_scope_by (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
req) MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text "with locally defined module" MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleSource -> MsgDoc
in_scope_by (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
prov) MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text "as this would create a cyclic dependency, which GHC does not support." MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text "Try moving this module to a separate library, e.g.," MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text "create a new stanza: library 'sublib'."
      _ -> () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ()
r <- ModuleWithSourceU s -> ModuleWithSourceU s -> UnifyM s (Maybe ())
forall s.
WithSource (ModuleU s)
-> WithSource (ModuleU s) -> UnifyM s (Maybe ())
unify ModuleWithSourceU s
prov ModuleWithSourceU s
req
    case Maybe ()
r of
        Just () -> () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Nothing -> do
            -- TODO: Record and report WHERE the bad constraint came from
            MsgDoc -> UnifyM s ()
forall s. MsgDoc -> UnifyM s ()
addErr (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Could not instantiate requirement" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name) MsgDoc -> MsgDoc -> MsgDoc
$$
                     Int -> MsgDoc -> MsgDoc
nest 4 (String -> MsgDoc
text "Expected:" MsgDoc -> MsgDoc -> MsgDoc
<+> OpenModule -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty OpenModule
mod MsgDoc -> MsgDoc -> MsgDoc
$$
                             String -> MsgDoc
text "Actual:  " MsgDoc -> MsgDoc -> MsgDoc
<+> OpenModule -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty OpenModule
req_mod) MsgDoc -> MsgDoc -> MsgDoc
$$
                     MsgDoc -> MsgDoc
parens (String -> MsgDoc
text "This can occur if an exposed module of" MsgDoc -> MsgDoc -> MsgDoc
<+>
                             String -> MsgDoc
text "a libraries shares a name with another module.") MsgDoc -> MsgDoc -> MsgDoc
$$
                     MsgDoc
link_doc
    [ModuleWithSourceU s] -> UnifyM s [ModuleWithSourceU s]
forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleWithSourceU s]
ret
  where
    unify :: WithSource (ModuleU s)
-> WithSource (ModuleU s) -> UnifyM s (Maybe ())
unify s1 :: WithSource (ModuleU s)
s1 s2 :: WithSource (ModuleU s)
s2 = UnifyM s () -> UnifyM s (Maybe ())
forall s a. UnifyM s a -> UnifyM s (Maybe a)
tryM (UnifyM s () -> UnifyM s (Maybe ()))
-> UnifyM s () -> UnifyM s (Maybe ())
forall a b. (a -> b) -> a -> b
$ MsgDoc -> UnifyM s () -> UnifyM s ()
forall s a. MsgDoc -> UnifyM s a -> UnifyM s a
addErrContext MsgDoc
short_link_doc
                       (UnifyM s () -> UnifyM s ()) -> UnifyM s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ ModuleU s -> ModuleU s -> UnifyM s ()
forall s. ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule (WithSource (ModuleU s) -> ModuleU s
forall a. WithSource a -> a
unWithSource WithSource (ModuleU s)
s1) (WithSource (ModuleU s) -> ModuleU s
forall a. WithSource a -> a
unWithSource WithSource (ModuleU s)
s2)
    in_scope_by :: ModuleSource -> MsgDoc
in_scope_by s :: ModuleSource
s = String -> MsgDoc
text "brought into scope by" MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleSource -> MsgDoc
dispModuleSource ModuleSource
s
    short_link_doc :: MsgDoc
short_link_doc = String -> MsgDoc
text "While filling requirement" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name)
    link_doc :: MsgDoc
link_doc = String -> MsgDoc
text "While filling requirements of" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
reqs_doc
    reqs_doc :: MsgDoc
reqs_doc
      | [ModuleWithSourceU s] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleWithSourceU s]
reqs = ModuleSource -> MsgDoc
dispModuleSource (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
req)
      | Bool
otherwise =  (       String -> MsgDoc
text "   " MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleSource -> MsgDoc
dispModuleSource (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
req)  MsgDoc -> MsgDoc -> MsgDoc
$$
                      [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "and" MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleSource -> MsgDoc
dispModuleSource (ModuleWithSourceU s -> ModuleSource
forall a. WithSource a -> ModuleSource
getSource ModuleWithSourceU s
r) | ModuleWithSourceU s
r <- [ModuleWithSourceU s]
reqs])
linkProvision _ _ _ = String -> UnifyM s [ModuleWithSourceU s]
forall a. HasCallStack => String -> a
error "linkProvision"



-----------------------------------------------------------------------
-- The unification algorithm

-- This is based off of https://gist.github.com/amnn/559551517d020dbb6588
-- which is a translation from Huet's thesis.

unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId uid1_u :: UnitIdU s
uid1_u uid2_u :: UnitIdU s
uid2_u
    | UnitIdU s
uid1_u UnitIdU s -> UnitIdU s -> Bool
forall a. Eq a => a -> a -> Bool
== UnitIdU s
uid2_u = () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        UnitIdU' s
xuid1 <- 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
uid1_u
        UnitIdU' s
xuid2 <- 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
uid2_u
        case (UnitIdU' s
xuid1, UnitIdU' s
xuid2) of
            (UnitIdThunkU u1 :: DefUnitId
u1, UnitIdThunkU u2 :: DefUnitId
u2)
                | DefUnitId
u1 DefUnitId -> DefUnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DefUnitId
u2  -> () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise ->
                    MsgDoc -> UnifyM s ()
forall s a. MsgDoc -> UnifyM s a
failWith (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Couldn't match unit IDs:") 4
                               (String -> MsgDoc
text "   " MsgDoc -> MsgDoc -> MsgDoc
<+> DefUnitId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty DefUnitId
u1 MsgDoc -> MsgDoc -> MsgDoc
$$
                                String -> MsgDoc
text "and" MsgDoc -> MsgDoc -> MsgDoc
<+> DefUnitId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty DefUnitId
u2)
            (UnitIdThunkU uid1 :: DefUnitId
uid1, UnitIdU _ cid2 :: ComponentId
cid2 insts2 :: Map ModuleName (ModuleU s)
insts2)
                -> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
forall s.
ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
unifyThunkWith ComponentId
cid2 Map ModuleName (ModuleU s)
insts2 UnitIdU s
uid2_u DefUnitId
uid1 UnitIdU s
uid1_u
            (UnitIdU _ cid1 :: ComponentId
cid1 insts1 :: Map ModuleName (ModuleU s)
insts1, UnitIdThunkU uid2 :: DefUnitId
uid2)
                -> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
forall s.
ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
unifyThunkWith ComponentId
cid1 Map ModuleName (ModuleU s)
insts1 UnitIdU s
uid1_u DefUnitId
uid2 UnitIdU s
uid2_u
            (UnitIdU _ cid1 :: ComponentId
cid1 insts1 :: Map ModuleName (ModuleU s)
insts1, UnitIdU _ cid2 :: ComponentId
cid2 insts2 :: Map ModuleName (ModuleU s)
insts2)
                -> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
forall s.
ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
unifyInner ComponentId
cid1 Map ModuleName (ModuleU s)
insts1 UnitIdU s
uid1_u ComponentId
cid2 Map ModuleName (ModuleU s)
insts2 UnitIdU s
uid2_u

unifyThunkWith :: ComponentId
               -> Map ModuleName (ModuleU s)
               -> UnitIdU s
               -> DefUnitId
               -> UnitIdU s
               -> UnifyM s ()
unifyThunkWith :: ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> DefUnitId
-> UnitIdU s
-> UnifyM s ()
unifyThunkWith cid1 :: ComponentId
cid1 insts1 :: Map ModuleName (ModuleU s)
insts1 uid1_u :: UnitIdU s
uid1_u uid2 :: DefUnitId
uid2 uid2_u :: UnitIdU s
uid2_u = do
    FullDb
db <- (UnifEnv s -> FullDb) -> UnifyM s (UnifEnv s) -> UnifyM s FullDb
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnifEnv s -> FullDb
forall s. UnifEnv s -> FullDb
unify_db UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
    let FullUnitId cid2 :: ComponentId
cid2 insts2' :: OpenModuleSubst
insts2' = FullDb -> FullDb
expandUnitId FullDb
db DefUnitId
uid2
    Map ModuleName (ModuleU s)
insts2 <- OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
forall s. OpenModuleSubst -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst OpenModuleSubst
insts2'
    ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
forall s.
ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
unifyInner ComponentId
cid1 Map ModuleName (ModuleU s)
insts1 UnitIdU s
uid1_u ComponentId
cid2 Map ModuleName (ModuleU s)
insts2 UnitIdU s
uid2_u

unifyInner :: ComponentId
           -> Map ModuleName (ModuleU s)
           -> UnitIdU s
           -> ComponentId
           -> Map ModuleName (ModuleU s)
           -> UnitIdU s
           -> UnifyM s ()
unifyInner :: ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> ComponentId
-> Map ModuleName (ModuleU s)
-> UnitIdU s
-> UnifyM s ()
unifyInner cid1 :: ComponentId
cid1 insts1 :: Map ModuleName (ModuleU s)
insts1 uid1_u :: UnitIdU s
uid1_u cid2 :: ComponentId
cid2 insts2 :: Map ModuleName (ModuleU s)
insts2 uid2_u :: UnitIdU s
uid2_u = do
    Bool -> UnifyM s () -> UnifyM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ComponentId
cid1 ComponentId -> ComponentId -> Bool
forall a. Eq a => a -> a -> Bool
/= ComponentId
cid2) (UnifyM s () -> UnifyM s ()) -> UnifyM s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
        -- TODO: if we had a package identifier, could be an
        -- easier to understand error message.
        MsgDoc -> UnifyM s ()
forall s a. MsgDoc -> UnifyM s a
failWith (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
            MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Couldn't match component IDs:") 4
                 (String -> MsgDoc
text "   " MsgDoc -> MsgDoc -> MsgDoc
<+> ComponentId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ComponentId
cid1 MsgDoc -> MsgDoc -> MsgDoc
$$
                  String -> MsgDoc
text "and" MsgDoc -> MsgDoc -> MsgDoc
<+> ComponentId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ComponentId
cid2)
    -- The KEY STEP which makes this a Huet-style unification
    -- algorithm.  (Also a payoff of using union-find.)
    -- We can build infinite unit IDs this way, which is necessary
    -- for support mutual recursion. NB: union keeps the SECOND
    -- descriptor, so we always arrange for a UnitIdThunkU to live
    -- there.
    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
uid1_u UnitIdU s
uid2_u
    Map ModuleName (UnifyM s ()) -> UnifyM s ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
F.sequenceA_ (Map ModuleName (UnifyM s ()) -> UnifyM s ())
-> Map ModuleName (UnifyM s ()) -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$ (ModuleU s -> ModuleU s -> UnifyM s ())
-> Map ModuleName (ModuleU s)
-> Map ModuleName (ModuleU s)
-> Map ModuleName (UnifyM s ())
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith ModuleU s -> ModuleU s -> UnifyM s ()
forall s. ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule Map ModuleName (ModuleU s)
insts1 Map ModuleName (ModuleU s)
insts2

-- | Imperatively unify two modules.
unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule mod1_u :: ModuleU s
mod1_u mod2_u :: ModuleU s
mod2_u
    | ModuleU s
mod1_u ModuleU s -> ModuleU s -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleU s
mod2_u = () -> UnifyM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        ModuleU' s
mod1 <- 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
mod1_u
        ModuleU' s
mod2 <- 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
mod2_u
        case (ModuleU' s
mod1, ModuleU' s
mod2) of
            (ModuleVarU _, _) -> 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
$ ModuleU s -> ModuleU s -> ST s ()
forall s a. Point s a -> Point s a -> ST s ()
UnionFind.union ModuleU s
mod1_u ModuleU s
mod2_u
            (_, ModuleVarU _) -> 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
$ ModuleU s -> ModuleU s -> ST s ()
forall s a. Point s a -> Point s a -> ST s ()
UnionFind.union ModuleU s
mod2_u ModuleU s
mod1_u
            (ModuleU uid1 :: UnitIdU s
uid1 mod_name1 :: ModuleName
mod_name1, ModuleU uid2 :: UnitIdU s
uid2 mod_name2 :: ModuleName
mod_name2) -> do
                Bool -> UnifyM s () -> UnifyM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
mod_name1 ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
mod_name2) (UnifyM s () -> UnifyM s ()) -> UnifyM s () -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
                    MsgDoc -> UnifyM s ()
forall s a. MsgDoc -> UnifyM s a
failWith (MsgDoc -> UnifyM s ()) -> MsgDoc -> UnifyM s ()
forall a b. (a -> b) -> a -> b
$
                        MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Cannot match module names") 4 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
                            String -> MsgDoc
text "   " MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name1 MsgDoc -> MsgDoc -> MsgDoc
$$
                            String -> MsgDoc
text "and" MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name2
                -- NB: this is not actually necessary (because we'll
                -- detect loops eventually in 'unifyUnitId'), but it
                -- seems harmless enough
                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
$ ModuleU s -> ModuleU s -> ST s ()
forall s a. Point s a -> Point s a -> ST s ()
UnionFind.union ModuleU s
mod1_u ModuleU s
mod2_u
                UnitIdU s -> UnitIdU s -> UnifyM s ()
forall s. UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId UnitIdU s
uid1 UnitIdU s
uid2