Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 module Distribution.Types.ModuleRenaming
   6   ( ModuleRenaming (..)
   7   , interpModuleRenaming
   8   , defaultRenaming
   9   , isDefaultRenaming
  10   ) where
  11
  12 import Distribution.CabalSpecVersion
  13 import Distribution.Compat.Prelude hiding (empty)
  14 import Prelude ()
  15
  16 import Distribution.ModuleName
  17 import Distribution.Parsec
  18 import Distribution.Pretty
  19
  20 import qualified Data.Map as Map
  21 import qualified Data.Set as Set
  22 import qualified Distribution.Compat.CharParsing as P
  23 import Text.PrettyPrint (comma, hsep, parens, punctuate, text)
  24
  25 -- | Renaming applied to the modules provided by a package.
  26 -- The boolean indicates whether or not to also include all of the
  27 -- original names of modules.  Thus, @ModuleRenaming False []@ is
  28 -- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@
  29 -- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".
  30 -- If a renaming is omitted you get the 'DefaultRenaming'.
  31 --
  32 -- (NB: This is a list not a map so that we can preserve order.)
  33 data ModuleRenaming
  34   = -- | A module renaming/thinning; e.g., @(A as B, C as C)@
  35     -- brings @B@ and @C@ into scope.
  36     ModuleRenaming [(ModuleName, ModuleName)]
  37   | -- | The default renaming, bringing all exported modules
  38     -- into scope.
  39     DefaultRenaming
  40   | -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all
  41     -- exported modules into scope except the hidden ones.
  42     HidingRenaming [ModuleName]
  43   deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
  44
  45 -- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName'
  46 -- to 'ModuleName'.  For efficiency, you should partially apply it
  47 -- with 'ModuleRenaming' and then reuse it.
  48 interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName
  49 interpModuleRenaming DefaultRenaming = Just
  50 interpModuleRenaming (ModuleRenaming rns) =
  51   let m = Map.fromList rns
  52    in \k -> Map.lookup k m
  53 interpModuleRenaming (HidingRenaming hs) =
  54   let s = Set.fromList hs
  55    in \k -> if k `Set.member` s then Nothing else Just k
  56
  57 -- | The default renaming, if something is specified in @build-depends@
  58 -- only.
  59 defaultRenaming :: ModuleRenaming
  60 defaultRenaming = DefaultRenaming
  61
  62 -- | Tests if its the default renaming; we can use a more compact syntax
  63 -- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case.
  64 isDefaultRenaming :: ModuleRenaming -> Bool
  65 isDefaultRenaming DefaultRenaming = True
  66 isDefaultRenaming _ = False
  67
  68 instance Binary ModuleRenaming
  69 instance Structured ModuleRenaming
  70
  71 instance NFData ModuleRenaming where rnf = genericRnf
  72
  73 -- NB: parentheses are mandatory, because later we may extend this syntax
  74 -- to allow "hiding (A, B)" or other modifier words.
  75 instance Pretty ModuleRenaming where
  76   pretty DefaultRenaming = mempty
  77   pretty (HidingRenaming hides) =
  78     text "hiding" <+> parens (hsep (punctuate comma (map pretty hides)))
  79   pretty (ModuleRenaming rns) =
  80     parens . hsep $ punctuate comma (map dispEntry rns)
  81     where
  82       dispEntry (orig, new)
  83         | orig == new = pretty orig
  84         | otherwise = pretty orig <+> text "as" <+> pretty new
  85
  86 instance Parsec ModuleRenaming where
  87   parsec = do
  88     csv <- askCabalSpecVersion
  89     if csv >= CabalSpecV3_0
  90       then moduleRenamingParsec parensLax lexemeParsec
  91       else moduleRenamingParsec parensStrict parsec
  92     where
  93       -- For cabal spec versions < 3.0 white spaces were not skipped
  94       -- after the '(' and ')' tokens in the mixin field. This
  95       -- parser checks the cabal file version and does the correct
  96       -- skipping of spaces.
  97       parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p
  98       parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p
  99
 100       warnSpaces =
 101         P.optional $
 102           P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher"
 103
 104 moduleRenamingParsec
 105   :: CabalParsing m
 106   => (forall a. m a -> m a)
 107   -- ^ between parens
 108   -> m ModuleName
 109   -- ^ module name parser
 110   -> m ModuleRenaming
 111 moduleRenamingParsec bp mn =
 112   -- NB: try not necessary as the first token is obvious
 113   P.choice [parseRename, parseHiding, return DefaultRenaming]
 114   where
 115     cma = P.char ',' >> P.spaces
 116     parseRename = do
 117       rns <- bp parseList
 118       P.spaces
 119       return (ModuleRenaming rns)
 120     parseHiding = do
 121       _ <- P.string "hiding"
 122       P.spaces -- space isn't strictly required as next is an open paren
 123       hides <- bp (P.sepBy mn cma)
 124       return (HidingRenaming hides)
 125     parseList =
 126       P.sepBy parseEntry cma
 127     parseEntry = do
 128       orig <- parsec
 129       P.spaces
 130       P.option (orig, orig) $ do
 131         _ <- P.string "as"
 132         P.skipSpaces1 -- require space after "as"
 133         new <- parsec
 134         P.spaces
 135         return (orig, new)