Network/HTTP/Lucu/Implant/Rewrite.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , GeneralizedNewtypeDeriving
   4   , MultiParamTypeClasses
   5   , RecordWildCards
   6   , TemplateHaskell
   7   , UnicodeSyntax
   8   #-}
   9 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
  10 -- |An internal module for rewriting 'Name's in Template Haskell AST.
  11 module Network.HTTP.Lucu.Implant.Rewrite
  12     ( NamePat(..)
  13     , RewriteOp(..)
  14
  15     , Imports
  16     , ImportOp(..)
  17
  18     , Rules
  19     , RewriteRule(..)
  20     , qualifyAll
  21     , unqualify
  22     , unqualifyIn
  23     , unqualifyAll
  24
  25     , rewriteNames
  26     )
  27     where
  28 import Control.Applicative hiding (empty)
  29 import Control.Monad.State
  30 import Data.Collections
  31 import Data.Collections.BaseInstances ()
  32 import qualified Data.Collections.Newtype.TH as C
  33 import Data.Data
  34 import Data.Generics.Aliases hiding (GT)
  35 import Data.Generics.Schemes
  36 import Data.Monoid
  37 import Data.Monoid.Unicode
  38 import qualified Data.Set as S (Set)
  39 import Language.Haskell.TH.Syntax
  40 import Prelude
  41 import Prelude.Unicode
  42
  43 -- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
  44 -- and 'Nothing' represensts a wildcard.
  45 data NamePat
  46     = NamePat !(Maybe ModName) !(Maybe OccName)
  47
  48 -- |Instruction for rewriting 'Name's.
  49 data RewriteOp
  50     = Identity
  51     | Unqualify
  52     | Qualify !ModName
  53
  54 -- |A 'Set' of modules and names to be imported.
  55 newtype Imports = Imports (S.Set ImportOp)
  56
  57 -- |Instruction for declaring module imports.
  58 data ImportOp
  59     = -- |> import qualified M as A
  60       QualifiedImp {
  61         impModule ∷ !ModName
  62       , impAlias  ∷ !ModName
  63       }
  64       -- |> import M
  65       --
  66       -- or
  67       --
  68       -- > import M (a, b, c, ...)
  69     | UnqualifiedImp {
  70         impModule ∷ !ModName
  71       , impNames  ∷ !(Maybe (S.Set (NameSpace, OccName)))
  72       }
  73     deriving Eq
  74
  75 -- |List of 'RewriteRule's.
  76 type Rules = [RewriteRule]
  77
  78 -- |Instruction for rewriting 'Name's and declaring module imports.
  79 data RewriteRule
  80     = RewriteRule {
  81         rrPat  ∷ !NamePat
  82       , rrOp   ∷ !RewriteOp
  83       , rrImps ∷ !Imports
  84       }
  85
  86 C.derive [d| instance Foldable   Imports ImportOp
  87              instance Collection Imports ImportOp
  88              instance Map        Imports ImportOp ()
  89              instance Set        Imports ImportOp
  90              instance SortingCollection Imports ImportOp
  91            |]
  92
  93 -- |@'insert' imp@ merges @imp@ with an existing one if any.
  94 instance Unfoldable Imports ImportOp where
  95     insert qi@(QualifiedImp   {}) (Imports s) = Imports $ insert qi s
  96     insert ui@(UnqualifiedImp {}) (Imports s)
  97         = case find sameMod s of
  98             Nothing  → Imports $ insert ui s
  99             Just ui' → Imports $ insert (merge ui') (delete ui' s)
 100         where
 101           sameMod ∷ ImportOp → Bool
 102           sameMod ui'@(UnqualifiedImp {})
 103               = impModule ui ≡ impModule ui'
 104           sameMod _
 105               = False
 106
 107           merge ∷ ImportOp → ImportOp
 108           merge ui'
 109               = case (impNames ui, impNames ui') of
 110                   (Nothing, _       ) → ui
 111                   (_      , Nothing ) → ui'
 112                   (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
 113
 114     empty     = Imports empty
 115     singleton = Imports ∘ singleton
 116
 117 instance Monoid Imports where
 118     mempty  = empty
 119     mappend = insertMany
 120
 121 instance Ord ImportOp where
 122     α `compare` β
 123         | impModule α < impModule β = LT
 124         | impModule α > impModule β = GT
 125         | otherwise
 126             = case (α, β) of
 127                 (QualifiedImp   {}, QualifiedImp   {})
 128                     → impAlias α `compare` impAlias β
 129                 (QualifiedImp   {}, _                )
 130                     → GT
 131                 (UnqualifiedImp {}, UnqualifiedImp {})
 132                     → impNames α `compare` impNames β
 133                 (UnqualifiedImp {}, _                )
 134                     → LT
 135
 136 -- |@'qualifyAll' module alias@: qualify every symbols defined in
 137 -- @module@ with @alias@.
 138 qualifyAll ∷ String → String → RewriteRule
 139 qualifyAll m a
 140     = let pat = NamePat (Just (mkModName m)) Nothing
 141           rop = Qualify (mkModName a)
 142           iop = QualifiedImp (mkModName m) (mkModName a)
 143       in
 144         RewriteRule pat rop (singleton iop)
 145
 146 -- |@'unqualify' name module@: unqualify the symbol @name@ with
 147 -- importing @module@.
 148 unqualify ∷ Name → String → RewriteRule
 149 unqualify (Name o _) m
 150     = let pat = NamePat Nothing (Just o)
 151           iop = UnqualifiedImp (mkModName m) ∘ Just
 152                 $ singleton (VarName, o)
 153       in
 154         RewriteRule pat Unqualify (singleton iop)
 155
 156 -- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
 157 -- name, or whatever resides in the type or class @tycl@ with
 158 -- importing @module@.
 159 unqualifyIn ∷ Name → Name → String → RewriteRule
 160 unqualifyIn (Name name _) (Name tycl _) m
 161     = let pat = NamePat Nothing (Just name)
 162           iop = UnqualifiedImp (mkModName m) ∘ Just
 163                 $ singleton (TcClsName, tycl)
 164       in
 165         RewriteRule pat Unqualify (singleton iop)
 166
 167 -- |@'unqualifyAll' origMod impMod@: unqualify every symbols
 168 -- defined in @origMod@ with importing @impMod@.
 169 unqualifyAll ∷ String → String → RewriteRule
 170 unqualifyAll origMod impMod
 171     = let pat = NamePat (Just (mkModName origMod)) Nothing
 172           iop = UnqualifiedImp (mkModName impMod) Nothing
 173       in
 174         RewriteRule pat Unqualify (singleton iop)
 175
 176 -- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
 177 -- in @d@ according to the name-rewriting @rules@ while at the same
 178 -- time building a set of modules to be imported.
 179 rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports)
 180 rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
 181     where
 182       f ∷ (Functor m, Monad m) ⇒ Name → StateT Imports m Name
 183       f n = case findRule rules n of
 184               Nothing → fail $ "No rules matches to name: " ⧺ showName n
 185               Just r  → applyRule r n
 186
 187 findRule ∷ Rules → Name → Maybe RewriteRule
 188 findRule _  (Name _  NameS       ) = Just identityRule
 189 findRule rs (Name o (NameQ     m)) = find (matchPat m o ∘ rrPat) rs
 190 findRule _  (Name _ (NameU _    )) = Just identityRule
 191 findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
 192 findRule _  _                      = Nothing
 193
 194 identityRule ∷ RewriteRule
 195 identityRule = RewriteRule {
 196                  rrPat  = NamePat Nothing Nothing
 197                , rrOp   = Identity
 198                , rrImps = (∅)
 199                }
 200
 201 matchPat ∷ ModName → OccName → NamePat → Bool
 202 matchPat m o (NamePat mp op)
 203     = maybe True (≡ m) mp ∧ maybe True (≡ o) op
 204
 205 applyRule ∷ (Functor m, Monad m)
 206           ⇒ RewriteRule
 207           → Name
 208           → StateT Imports m Name
 209 applyRule (RewriteRule {..}) n
 210     = modify (⊕ rrImps) *> pure (rewrite rrOp n)
 211
 212 rewrite ∷ RewriteOp → Name → Name
 213 rewrite Identity    n          = n
 214 rewrite Unqualify   (Name o _) = Name o NameS
 215 rewrite (Qualify m) (Name o _) = Name o (NameQ m)