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)