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 -- |@'insert' imp@ merges @imp@ with an existing one if any.
85 instance Unfoldable Imports ImportOp where
86 insert qi@(QualifiedImp {}) (Imports s) = Imports $ insert qi s
87 insert ui@(UnqualifiedImp {}) (Imports s)
88 = case find sameMod s of
89 Nothing → Imports $ insert ui s
90 Just ui' → Imports $ insert (merge ui') (delete ui' s)
92 sameMod ∷ ImportOp → Bool
93 sameMod ui'@(UnqualifiedImp {})
94 = impModule ui ≡ impModule ui'
98 merge ∷ ImportOp → ImportOp
100 = case (impNames ui, impNames ui') of
103 (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
105 empty = Imports empty
106 singleton = Imports ∘ singleton
108 -- FIXME: auto-derive
109 instance Foldable Imports ImportOp where
110 foldr f b (Imports s) = foldr f b s
112 -- FIXME: auto-derive
113 instance Collection Imports ImportOp where
114 filter f (Imports s) = Imports $ filter f s
116 instance Monoid Imports where
120 -- FIXME: auto-derive
121 instance Map Imports ImportOp () where
122 lookup k (Imports s) = lookup k s
123 mapWithKey f (Imports m)
124 = Imports $ mapWithKey f m
125 unionWith f (Imports α) (Imports β)
126 = Imports $ unionWith f α β
127 intersectionWith f (Imports α) (Imports β)
128 = Imports $ intersectionWith f α β
129 differenceWith f (Imports α) (Imports β)
130 = Imports $ differenceWith f α β
131 isSubmapBy f (Imports α) (Imports β)
133 isProperSubmapBy f (Imports α) (Imports β)
134 = isProperSubmapBy f α β
136 -- FIXME: auto-derive
137 instance Set Imports ImportOp where
138 haddock_candy = haddock_candy
140 -- FIXME: auto-derive
141 instance SortingCollection Imports ImportOp where
142 minView (Imports s) = second Imports <$> minView s
144 instance Ord ImportOp where
146 | impModule α < impModule β = LT
147 | impModule α > impModule β = GT
150 (QualifiedImp {}, QualifiedImp {})
151 → impAlias α `compare` impAlias β
152 (QualifiedImp {}, _ )
154 (UnqualifiedImp {}, UnqualifiedImp {})
155 → impNames α `compare` impNames β
156 (UnqualifiedImp {}, _ )
159 -- |@'qualifyAll' module alias@: qualify every symbols defined in
160 -- @module@ with @alias@.
161 qualifyAll ∷ String → String → RewriteRule
163 = let pat = NamePat (Just (mkModName m)) Nothing
164 rop = Qualify (mkModName a)
165 iop = QualifiedImp (mkModName m) (mkModName a)
167 RewriteRule pat rop (singleton iop)
169 -- |@'unqualify' name module@: unqualify the symbol @name@ with
170 -- importing @module@.
171 unqualify ∷ Name → String → RewriteRule
172 unqualify (Name o _) m
173 = let pat = NamePat Nothing (Just o)
174 iop = UnqualifiedImp (mkModName m) ∘ Just
175 $ singleton (VarName, o)
177 RewriteRule pat Unqualify (singleton iop)
179 -- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
180 -- name, or whatever resides in the type or class @tycl@ with
181 -- importing @module@.
182 unqualifyIn ∷ Name → Name → String → RewriteRule
183 unqualifyIn (Name name _) (Name tycl _) m
184 = let pat = NamePat Nothing (Just name)
185 iop = UnqualifiedImp (mkModName m) ∘ Just
186 $ singleton (TcClsName, tycl)
188 RewriteRule pat Unqualify (singleton iop)
190 -- |@'unqualifyAll' origMod impMod@: unqualify every symbols
191 -- defined in @origMod@ with importing @impMod@.
192 unqualifyAll ∷ String → String → RewriteRule
193 unqualifyAll origMod impMod
194 = let pat = NamePat (Just (mkModName origMod)) Nothing
195 iop = UnqualifiedImp (mkModName impMod) Nothing
197 RewriteRule pat Unqualify (singleton iop)
199 -- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
200 -- in @d@ according to the name-rewriting @rules@ while at the same
201 -- time building a set of modules to be imported.
202 rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports)
203 rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
205 f ∷ (Functor m, Monad m) ⇒ Name → StateT Imports m Name
206 f n = case findRule rules n of
207 Nothing → fail $ "No rules matches to name: " ⧺ showName n
208 Just r → applyRule r n
210 findRule ∷ Rules → Name → Maybe RewriteRule
211 findRule _ (Name _ NameS ) = Just identityRule
212 findRule rs (Name o (NameQ m)) = find (matchPat m o ∘ rrPat) rs
213 findRule _ (Name _ (NameU _ )) = Just identityRule
214 findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
215 findRule _ _ = Nothing
217 identityRule ∷ RewriteRule
218 identityRule = RewriteRule {
219 rrPat = NamePat Nothing Nothing
224 matchPat ∷ ModName → OccName → NamePat → Bool
225 matchPat m o (NamePat mp op)
226 = maybe True (≡ m) mp ∧ maybe True (≡ o) op
228 applyRule ∷ (Functor m, Monad m)
231 → StateT Imports m Name
232 applyRule (RewriteRule {..}) n
233 = modify (⊕ rrImps) *> pure (rewrite rrOp n)
235 rewrite ∷ RewriteOp → Name → Name
236 rewrite Identity n = n
237 rewrite Unqualify (Name o _) = Name o NameS
238 rewrite (Qualify m) (Name o _) = Name o (NameQ m)