Network/HTTP/Lucu/Implant/Rewrite.hs

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