    {-# LANGUAGE NondecreasingIndentation #-}

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

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

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

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

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

    -----------------------------------------------------------------------
    -- 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
        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)
        mod' <- convertModuleU (unWithSource prov')
        r <- unify prov prov'
        case 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
      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)
      req_mod <- convertModuleU (unWithSource req)
      self_cid <- fmap unify_self_cid getUnifEnv
      case 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 ()
      r <- unify prov req
      case 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
      return 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
          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
          xuid2 <- liftST $ UnionFind.find uid2_u
          case (xuid1, 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
      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 cid2 insts2' = expandUnitId db uid2
      insts2 <- convertModuleSubst insts2'
      unifyInner cid1 insts1 uid1_u cid2 insts2 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
          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
          mod2 <- liftST $ UnionFind.find mod2_u
          case (mod1, 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