ModuleScope.hs

{-# LANGUAGE DeriveTraversable #-}

-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModuleScope
  ( -- * Module scopes
    ModuleScope (..)
  , ModuleProvides
  , ModuleRequires
  , ModuleSource (..)
  , dispModuleSource
  , WithSource (..)
  , unWithSource
  , getSource
  , ModuleWithSource
  , emptyModuleScope
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.ModuleName
import Distribution.Pretty
import Distribution.Types.ComponentName
import Distribution.Types.IncludeRenaming
import Distribution.Types.LibraryName
import Distribution.Types.PackageName

import Distribution.Backpack
import Distribution.Backpack.ModSubst

import qualified Data.Map as Map
import Text.PrettyPrint

-----------------------------------------------------------------------
-- Module scopes

-- Why is ModuleProvides so complicated?  The basic problem is that
-- we want to support this:
--
--  package p where
--      include q (A)
--      include r (A)
--      module B where
--          import "q" A
--          import "r" A
--
-- Specifically, in Cabal today it is NOT an error have two modules in
-- scope with the same identifier.  So we need to preserve this for
-- Backpack.  The modification is that an ambiguous module name is
-- OK... as long as it is NOT used to fill a requirement!
--
-- So as a first try, we might try deferring unifying provisions that
-- are being glommed together, and check for equality after the fact.
-- But this doesn't work, because what if a multi-module provision
-- is used to fill a requirement?!  So you do the equality test
-- IMMEDIATELY before a requirement fill happens... or never at all.
--
-- Alternate strategy: go ahead and unify, and then if it is revealed
-- that some requirements got filled "out-of-thin-air", error.

-- | A 'ModuleScope' describes the modules and requirements that
-- are in-scope as we are processing a Cabal package.  Unlike
-- a 'ModuleShape', there may be multiple modules in scope at
-- the same 'ModuleName'; this is only an error if we attempt
-- to use those modules to fill a requirement.  A 'ModuleScope'
-- can influence the 'ModuleShape' via a reexport.
data ModuleScope = ModuleScope
  { modScopeProvides :: ModuleProvides
  , modScopeRequires :: ModuleRequires
  }

-- | An empty 'ModuleScope'.
emptyModuleScope :: ModuleScope
emptyModuleScope = ModuleScope Map.empty Map.empty

-- | Every 'Module' in scope at a 'ModuleName' is annotated with
-- the 'PackageName' it comes from.
type ModuleProvides = Map ModuleName [ModuleWithSource]

-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m
type ModuleRequires = Map ModuleName [ModuleWithSource]

-- TODO: consider newtping the two types above.

-- | Description of where a module participating in mixin linking came
-- from.
data ModuleSource
  = FromMixins PackageName ComponentName IncludeRenaming
  | FromBuildDepends PackageName ComponentName
  | FromExposedModules ModuleName
  | FromOtherModules ModuleName
  | FromSignatures ModuleName

-- We don't have line numbers, but if we did, we'd want to record that
-- too

-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg
dispModuleSource :: ModuleSource -> Doc
dispModuleSource (FromMixins pn cn incls) =
  text "mixins:" <+> dispComponent pn cn <+> pretty incls
dispModuleSource (FromBuildDepends pn cn) =
  text "build-depends:" <+> dispComponent pn cn
dispModuleSource (FromExposedModules m) =
  text "exposed-modules:" <+> pretty m
dispModuleSource (FromOtherModules m) =
  text "other-modules:" <+> pretty m
dispModuleSource (FromSignatures m) =
  text "signatures:" <+> pretty m

-- Dependency
dispComponent :: PackageName -> ComponentName -> Doc
dispComponent pn cn =
  -- NB: This syntax isn't quite the source syntax, but it
  -- should be clear enough.  To do source syntax, we'd
  -- need to know what the package we're linking is.
  case cn of
    CLibName LMainLibName -> pretty pn
    CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn
    -- Case below shouldn't happen
    _ -> pretty pn <+> parens (pretty cn)

-- | An 'OpenModule', annotated with where it came from in a Cabal file.
data WithSource a = WithSource ModuleSource a
  deriving (Functor, Foldable, Traversable)

unWithSource :: WithSource a -> a
unWithSource (WithSource _ x) = x
getSource :: WithSource a -> ModuleSource
getSource (WithSource s _) = s
type ModuleWithSource = WithSource OpenModule

instance ModSubst a => ModSubst (WithSource a) where
  modSubst subst (WithSource s m) = WithSource s (modSubst subst m)