3 , GeneralizedNewtypeDeriving
7 -- |An internal module for rewriting 'Name's in Template Haskell AST.
8 module Network.HTTP.Lucu.Implant.Rewrite
25 import Control.Applicative
26 import Control.Monad.State
29 import Data.Generics.Aliases hiding (GT)
30 import Data.Generics.Schemes
32 import Data.Monoid.Unicode
34 import qualified Data.Set as S
35 import Language.Haskell.TH.Syntax
37 import Prelude.Unicode
39 -- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
40 -- and 'Nothing' represensts a wildcard.
42 = NamePat !(Maybe ModName) !(Maybe OccName)
44 -- |Instruction for rewriting 'Name's.
50 -- |A 'Set' of modules and names to be imported.
51 newtype Imports α = Imports (Set α)
54 -- |Instruction for declaring module imports.
56 = -- |> import qualified M as A
65 -- > import M (a, b, c, ...)
68 , impNames ∷ !(Maybe (Set (NameSpace, OccName)))
72 -- |List of 'RewriteRule's.
73 type Rules = [RewriteRule]
75 -- |Instruction for rewriting 'Name's and declaring module imports.
80 , rrImps ∷ !(Imports ImportOp)
83 instance Ord ImportOp where
85 | impModule α < impModule β = LT
86 | impModule α > impModule β = GT
89 (QualifiedImp {}, QualifiedImp {})
90 → impAlias α `compare` impAlias β
93 (UnqualifiedImp {}, UnqualifiedImp {})
94 → impNames α `compare` impNames β
95 (UnqualifiedImp {}, _ )
98 instance Monoid (Imports ImportOp) where
101 mappend (Imports α) (Imports β)
102 = Imports (foldl' insertImp α β)
104 insertImp ∷ Set ImportOp → ImportOp → Set ImportOp
105 insertImp α qi@(QualifiedImp {}) = S.insert qi α
106 insertImp α ui@(UnqualifiedImp {})
107 = case find sameMod α of
108 Nothing → S.insert ui α
109 Just ui' → S.insert (merge ui') (S.delete ui' α)
111 sameMod ∷ ImportOp → Bool
112 sameMod ui'@(UnqualifiedImp {})
113 = impModule ui ≡ impModule ui'
117 merge ∷ ImportOp → ImportOp
119 = case (impNames ui, impNames ui') of
122 (Just s , Just s') → ui { impNames = Just (s ⊕ s') }
124 -- |@'qualifyAll' module alias@: qualify every symbols defined in
125 -- @module@ with @alias@.
126 qualifyAll ∷ String → String → RewriteRule
128 = let pat = NamePat (Just (mkModName m)) Nothing
129 rop = Qualify (mkModName a)
130 iop = QualifiedImp (mkModName m) (mkModName a)
132 RewriteRule pat rop (Imports (S.singleton iop))
134 -- |@'unqualify' name module@: unqualify the symbol @name@ with
135 -- importing @module@.
136 unqualify ∷ Name → String → RewriteRule
137 unqualify (Name o _) m
138 = let pat = NamePat Nothing (Just o)
139 iop = UnqualifiedImp (mkModName m)
141 $ S.singleton (VarName, o)
143 RewriteRule pat Unqualify (Imports (S.singleton iop))
145 -- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
146 -- name, or whatever resides in the type or class @tycl@ with
147 -- importing @module@.
148 unqualifyIn ∷ Name → Name → String → RewriteRule
149 unqualifyIn (Name name _) (Name tycl _) m
150 = let pat = NamePat Nothing (Just name)
151 iop = UnqualifiedImp (mkModName m)
153 $ S.singleton (TcClsName, tycl)
155 RewriteRule pat Unqualify (Imports (S.singleton iop))
157 -- |@'unqualifyAll' origMod impMod@: unqualify every symbols
158 -- defined in @origMod@ with importing @impMod@.
159 unqualifyAll ∷ String → String → RewriteRule
160 unqualifyAll origMod impMod
161 = let pat = NamePat (Just (mkModName origMod)) Nothing
162 iop = UnqualifiedImp (mkModName impMod) Nothing
164 RewriteRule pat Unqualify (Imports (S.singleton iop))
166 -- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
167 -- in @d@ according to the name-rewriting @rules@ while at the same
168 -- time building a set of modules to be imported.
169 rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp)
170 rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
172 f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name
173 f n = case findRule rules n of
174 Nothing → fail $ "No rules matches to name: " ⧺ showName n
175 Just r → applyRule r n
177 findRule ∷ Rules → Name → Maybe RewriteRule
178 findRule _ (Name _ NameS ) = Just identityRule
179 findRule rs (Name o (NameQ m)) = find (matchPat m o ∘ rrPat) rs
180 findRule _ (Name _ (NameU _ )) = Just identityRule
181 findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
182 findRule _ _ = Nothing
184 identityRule ∷ RewriteRule
185 identityRule = RewriteRule {
186 rrPat = NamePat Nothing Nothing
191 matchPat ∷ ModName → OccName → NamePat → Bool
192 matchPat m o (NamePat mp op)
193 = maybe True (≡ m) mp ∧ maybe True (≡ o) op
195 applyRule ∷ (Functor m, Monad m)
198 → StateT (Imports ImportOp) m Name
199 applyRule (RewriteRule {..}) n
200 = modify (⊕ rrImps) *> pure (rewrite rrOp n)
202 rewrite ∷ RewriteOp → Name → Name
203 rewrite Identity n = n
204 rewrite Unqualify (Name o _) = Name o NameS
205 rewrite (Qualify m) (Name o _) = Name o (NameQ m)