Network/HTTP/Lucu/Implant/Rewrite.hs

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