]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Implant/Rewrite.hs
affa89791d0cbe520fcc124e9232fadaea5978d7
[Lucu.git] / 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 -- |@'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)
91         where
92           sameMod ∷ ImportOp → Bool
93           sameMod ui'@(UnqualifiedImp {})
94               = impModule ui ≡ impModule ui'
95           sameMod _
96               = False
97
98           merge ∷ ImportOp → ImportOp
99           merge ui'
100               = case (impNames ui, impNames ui') of
101                   (Nothing, _       ) → ui
102                   (_      , Nothing ) → ui'
103                   (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
104
105     empty     = Imports empty
106     singleton = Imports ∘ singleton
107
108 -- FIXME: auto-derive
109 instance Foldable Imports ImportOp where
110     foldr f b (Imports s) = foldr f b s
111
112 -- FIXME: auto-derive
113 instance Collection Imports ImportOp where
114     filter f (Imports s) = Imports $ filter f s
115
116 instance Monoid Imports where
117     mempty  = empty
118     mappend = insertMany
119
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 β)
132         = isSubmapBy f α β
133     isProperSubmapBy f (Imports α) (Imports β)
134         = isProperSubmapBy f α β
135
136 -- FIXME: auto-derive
137 instance Set Imports ImportOp where
138     haddock_candy = haddock_candy
139
140 -- FIXME: auto-derive
141 instance SortingCollection Imports ImportOp where
142     minView (Imports s) = second Imports <$> minView s
143
144 instance Ord ImportOp where
145     α `compare` β
146         | impModule α < impModule β = LT
147         | impModule α > impModule β = GT
148         | otherwise
149             = case (α, β) of
150                 (QualifiedImp   {}, QualifiedImp   {})
151                     → impAlias α `compare` impAlias β
152                 (QualifiedImp   {}, _                )
153                     → GT
154                 (UnqualifiedImp {}, UnqualifiedImp {})
155                     → impNames α `compare` impNames β
156                 (UnqualifiedImp {}, _                )
157                     → LT
158
159 -- |@'qualifyAll' module alias@: qualify every symbols defined in
160 -- @module@ with @alias@.
161 qualifyAll ∷ String → String → RewriteRule
162 qualifyAll m a
163     = let pat = NamePat (Just (mkModName m)) Nothing
164           rop = Qualify (mkModName a)
165           iop = QualifiedImp (mkModName m) (mkModName a)
166       in
167         RewriteRule pat rop (singleton iop)
168
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)
175                 $ Just
176                 $ singleton (VarName, o)
177       in
178         RewriteRule pat Unqualify (singleton iop)
179
180 -- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
181 -- name, or whatever resides in the type or class @tycl@ with
182 -- importing @module@.
183 unqualifyIn ∷ Name → Name → String → RewriteRule
184 unqualifyIn (Name name _) (Name tycl _) m
185     = let pat = NamePat Nothing (Just name)
186           iop = UnqualifiedImp (mkModName m)
187                 $ Just
188                 $ singleton (TcClsName, tycl)
189       in
190         RewriteRule pat Unqualify (singleton iop)
191
192 -- |@'unqualifyAll' origMod impMod@: unqualify every symbols
193 -- defined in @origMod@ with importing @impMod@.
194 unqualifyAll ∷ String → String → RewriteRule
195 unqualifyAll origMod impMod
196     = let pat = NamePat (Just (mkModName origMod)) Nothing
197           iop = UnqualifiedImp (mkModName impMod) Nothing
198       in
199         RewriteRule pat Unqualify (singleton iop)
200
201 -- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
202 -- in @d@ according to the name-rewriting @rules@ while at the same
203 -- time building a set of modules to be imported.
204 rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports)
205 rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
206     where
207       f ∷ (Functor m, Monad m) ⇒ Name → StateT Imports m Name
208       f n = case findRule rules n of
209               Nothing → fail $ "No rules matches to name: " ⧺ showName n
210               Just r  → applyRule r n
211
212 findRule ∷ Rules → Name → Maybe RewriteRule
213 findRule _  (Name _  NameS       ) = Just identityRule
214 findRule rs (Name o (NameQ     m)) = find (matchPat m o ∘ rrPat) rs
215 findRule _  (Name _ (NameU _    )) = Just identityRule
216 findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
217 findRule _  _                      = Nothing
218
219 identityRule ∷ RewriteRule
220 identityRule = RewriteRule {
221                  rrPat  = NamePat Nothing Nothing
222                , rrOp   = Identity
223                , rrImps = (∅)
224                }
225
226 matchPat ∷ ModName → OccName → NamePat → Bool
227 matchPat m o (NamePat mp op)
228     = maybe True (≡ m) mp ∧ maybe True (≡ o) op
229
230 applyRule ∷ (Functor m, Monad m)
231           ⇒ RewriteRule
232           → Name
233           → StateT Imports m Name
234 applyRule (RewriteRule {..}) n
235     = modify (⊕ rrImps) *> pure (rewrite rrOp n)
236
237 rewrite ∷ RewriteOp → Name → Name
238 rewrite Identity    n          = n
239 rewrite Unqualify   (Name o _) = Name o NameS
240 rewrite (Qualify m) (Name o _) = Name o (NameQ m)