3 , GeneralizedNewtypeDeriving
4 , MultiParamTypeClasses
8 -- |An internal module for rewriting 'Name's in Template Haskell AST.
9 module Network.HTTP.Lucu.Implant.Rewrite
26 import Control.Applicative hiding (empty)
28 import Control.Monad.State
29 import Data.Collections
30 import Data.Collections.BaseInstances ()
32 import Data.Generics.Aliases hiding (GT)
33 import Data.Generics.Schemes
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
41 -- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
42 -- and 'Nothing' represensts a wildcard.
44 = NamePat !(Maybe ModName) !(Maybe OccName)
46 -- |Instruction for rewriting 'Name's.
52 -- |A 'Set' of modules and names to be imported.
53 newtype Imports = Imports (S.Set ImportOp)
55 -- |Instruction for declaring module imports.
57 = -- |> import qualified M as A
66 -- > import M (a, b, c, ...)
69 , impNames ∷ !(Maybe (S.Set (NameSpace, OccName)))
73 -- |List of 'RewriteRule's.
74 type Rules = [RewriteRule]
76 -- |Instruction for rewriting 'Name's and declaring module imports.
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)
91 sameMod ∷ ImportOp → Bool
92 sameMod ui'@(UnqualifiedImp {})
93 = impModule ui ≡ impModule ui'
97 merge ∷ ImportOp → ImportOp
99 = case (impNames ui, impNames ui') of
102 (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
104 instance Foldable Imports ImportOp where
105 foldr f b (Imports s) = foldr f b s
107 instance Collection Imports ImportOp where
108 filter f (Imports s) = Imports $ filter f s
110 instance Monoid Imports where
112 mappend (Imports α) (Imports β)
113 = Imports $ insertManySorted β α
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 β)
127 isProperSubmapBy f (Imports α) (Imports β)
128 = isProperSubmapBy f α β
130 instance Set Imports ImportOp where
131 haddock_candy = haddock_candy
133 instance SortingCollection Imports ImportOp where
134 minView (Imports s) = second Imports <$> minView s
136 instance Ord ImportOp where
138 | impModule α < impModule β = LT
139 | impModule α > impModule β = GT
142 (QualifiedImp {}, QualifiedImp {})
143 → impAlias α `compare` impAlias β
144 (QualifiedImp {}, _ )
146 (UnqualifiedImp {}, UnqualifiedImp {})
147 → impNames α `compare` impNames β
148 (UnqualifiedImp {}, _ )
151 -- |@'qualifyAll' module alias@: qualify every symbols defined in
152 -- @module@ with @alias@.
153 qualifyAll ∷ String → String → RewriteRule
155 = let pat = NamePat (Just (mkModName m)) Nothing
156 rop = Qualify (mkModName a)
157 iop = QualifiedImp (mkModName m) (mkModName a)
159 RewriteRule pat rop (singleton iop)
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)
168 $ singleton (VarName, o)
170 RewriteRule pat Unqualify (singleton iop)
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)
180 $ singleton (TcClsName, tycl)
182 RewriteRule pat Unqualify (singleton iop)
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
191 RewriteRule pat Unqualify (singleton iop)
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))
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
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
211 identityRule ∷ RewriteRule
212 identityRule = RewriteRule {
213 rrPat = NamePat Nothing Nothing
218 matchPat ∷ ModName → OccName → NamePat → Bool
219 matchPat m o (NamePat mp op)
220 = maybe True (≡ m) mp ∧ maybe True (≡ o) op
222 applyRule ∷ (Functor m, Monad m)
225 → StateT Imports m Name
226 applyRule (RewriteRule {..}) n
227 = modify (⊕ rrImps) *> pure (rewrite rrOp n)
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)