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