{-# 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 :: forall s. [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink [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 a. a -> UnifyM s a
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 :: forall s.
ModuleName
-> [ModuleWithSourceU s]
-> [ModuleWithSourceU s]
-> UnifyM s [ModuleWithSourceU s]
linkProvision ModuleName
mod_name ret :: [ModuleWithSourceU s]
ret@(ModuleWithSourceU s
prov:[ModuleWithSourceU s]
provs) (ModuleWithSourceU s
req:[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
$ \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 a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe ()
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 String
"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 String
"It could refer to" MsgDoc -> MsgDoc -> MsgDoc
<+>
                    ( String -> MsgDoc
text String
"  " 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 String
"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 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 -> 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 ComponentId
cid OpenModuleSubst
_) ModuleName
_
        | 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 String
"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 String
"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 String
"as this would create a cyclic dependency, which GHC does not support." MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text String
"Try moving this module to a separate library, e.g.," MsgDoc -> MsgDoc -> MsgDoc
$$
            String -> MsgDoc
text String
"create a new stanza: library 'sublib'."
      OpenModule
_ -> () -> UnifyM s ()
forall a. a -> UnifyM s a
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 a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe ()
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 String
"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 Int
4 (String -> MsgDoc
text String
"Expected:" MsgDoc -> MsgDoc -> MsgDoc
<+> OpenModule -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty OpenModule
mod MsgDoc -> MsgDoc -> MsgDoc
$$
                             String -> MsgDoc
text String
"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 String
"This can occur if an exposed module of" MsgDoc -> MsgDoc -> MsgDoc
<+>
                             String -> MsgDoc
text String
"a libraries shares a name with another module.") MsgDoc -> MsgDoc -> MsgDoc
$$
                     MsgDoc
link_doc
    [ModuleWithSourceU s] -> UnifyM s [ModuleWithSourceU s]
forall a. a -> UnifyM s a
forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleWithSourceU s]
ret
  where
    unify :: WithSource (ModuleU s)
-> WithSource (ModuleU s) -> UnifyM s (Maybe ())
unify WithSource (ModuleU s)
s1 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 ModuleSource
s = String -> MsgDoc
text String
"brought into scope by" MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleSource -> MsgDoc
dispModuleSource ModuleSource
s
    short_link_doc :: MsgDoc
short_link_doc = String -> MsgDoc
text String
"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 String
"While filling requirements of" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
reqs_doc
    reqs_doc :: MsgDoc
reqs_doc
      | [ModuleWithSourceU s] -> Bool
forall a. [a] -> 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 String
"   " 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 String
"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 ModuleName
_ [ModuleWithSourceU s]
_ [ModuleWithSourceU s]
_ = String -> UnifyM s [ModuleWithSourceU s]
forall a. HasCallStack => String -> a
error String
"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 :: forall s. UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId UnitIdU s
uid1_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 a. a -> UnifyM s a
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 DefUnitId
u1, UnitIdThunkU DefUnitId
u2)
                | DefUnitId
u1 DefUnitId -> DefUnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DefUnitId
u2  -> () -> UnifyM s ()
forall a. a -> UnifyM s a
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 String
"Couldn't match unit IDs:") Int
4
                               (String -> MsgDoc
text String
"   " MsgDoc -> MsgDoc -> MsgDoc
<+> DefUnitId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty DefUnitId
u1 MsgDoc -> MsgDoc -> MsgDoc
$$
                                String -> MsgDoc
text String
"and" MsgDoc -> MsgDoc -> MsgDoc
<+> DefUnitId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty DefUnitId
u2)
            (UnitIdThunkU DefUnitId
uid1, UnitIdU Int
_ ComponentId
cid2 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 Int
_ ComponentId
cid1 Map ModuleName (ModuleU s)
insts1, UnitIdThunkU 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 Int
_ ComponentId
cid1 Map ModuleName (ModuleU s)
insts1, UnitIdU Int
_ ComponentId
cid2 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 :: 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 = do
    FullDb
db <- (UnifEnv s -> FullDb) -> UnifyM s (UnifEnv s) -> UnifyM s FullDb
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 -> FullDb
forall s. UnifEnv s -> FullDb
unify_db UnifyM s (UnifEnv s)
forall s. UnifyM s (UnifEnv s)
getUnifEnv
    let FullUnitId ComponentId
cid2 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 :: 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 = 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 String
"Couldn't match component IDs:") Int
4
                 (String -> MsgDoc
text String
"   " MsgDoc -> MsgDoc -> MsgDoc
<+> ComponentId -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ComponentId
cid1 MsgDoc -> MsgDoc -> MsgDoc
$$
                  String -> MsgDoc
text String
"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 :: forall s. ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule ModuleU s
mod1_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 a. a -> UnifyM s a
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 ModuleName
_, ModuleU' s
_) -> 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
            (ModuleU' s
_, ModuleVarU ModuleName
_) -> 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 UnitIdU s
uid1 ModuleName
mod_name1, ModuleU UnitIdU s
uid2 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 String
"Cannot match module names") Int
4 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
                            String -> MsgDoc
text String
"   " MsgDoc -> MsgDoc -> MsgDoc
<+> ModuleName -> MsgDoc
forall a. Pretty a => a -> MsgDoc
pretty ModuleName
mod_name1 MsgDoc -> MsgDoc -> MsgDoc
$$
                            String -> MsgDoc
text String
"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