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) ∘ Just
 175                 $ singleton (VarName, o)
 176       in
 177         RewriteRule pat Unqualify (singleton iop)
 178
 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)
 187       in
 188         RewriteRule pat Unqualify (singleton iop)
 189
 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
 196       in
 197         RewriteRule pat Unqualify (singleton iop)
 198
 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))
 204     where
 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
 209
 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
 216
 217 identityRule ∷ RewriteRule
 218 identityRule = RewriteRule {
 219                  rrPat  = NamePat Nothing Nothing
 220                , rrOp   = Identity
 221                , rrImps = (∅)
 222                }
 223
 224 matchPat ∷ ModName → OccName → NamePat → Bool
 225 matchPat m o (NamePat mp op)
 226     = maybe True (≡ m) mp ∧ maybe True (≡ o) op
 227
 228 applyRule ∷ (Functor m, Monad m)
 229           ⇒ RewriteRule
 230           → Name
 231           → StateT Imports m Name
 232 applyRule (RewriteRule {..}) n
 233     = modify (⊕ rrImps) *> pure (rewrite rrOp n)
 234
 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)