{-# LANGUAGE
FlexibleInstances
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, RecordWildCards
+ , TemplateHaskell
, UnicodeSyntax
#-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-- |An internal module for rewriting 'Name's in Template Haskell AST.
module Network.HTTP.Lucu.Implant.Rewrite
( NamePat(..)
, rewriteNames
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
import Control.Monad.State
+import Data.Collections
+import Data.Collections.BaseInstances ()
+import qualified Data.Collections.Newtype.TH as C
import Data.Data
-import Data.Foldable
import Data.Generics.Aliases hiding (GT)
import Data.Generics.Schemes
import Data.Monoid
import Data.Monoid.Unicode
-import Data.Set (Set)
-import qualified Data.Set as S
+import qualified Data.Set as S (Set)
import Language.Haskell.TH.Syntax
import Prelude
import Prelude.Unicode
| Qualify !ModName
-- |A 'Set' of modules and names to be imported.
-newtype Imports α = Imports (Set α)
- deriving Foldable
+newtype Imports = Imports (S.Set ImportOp)
-- |Instruction for declaring module imports.
data ImportOp
-- > import M (a, b, c, ...)
| UnqualifiedImp {
impModule ∷ !ModName
- , impNames ∷ !(Maybe (Set (NameSpace, OccName)))
+ , impNames ∷ !(Maybe (S.Set (NameSpace, OccName)))
}
deriving Eq
= RewriteRule {
rrPat ∷ !NamePat
, rrOp ∷ !RewriteOp
- , rrImps ∷ !(Imports ImportOp)
+ , rrImps ∷ !Imports
}
+C.derive [d| instance Foldable Imports ImportOp
+ instance Collection Imports ImportOp
+ instance Map Imports ImportOp ()
+ instance Set Imports ImportOp
+ instance SortingCollection Imports ImportOp
+ |]
+
+-- |@'insert' imp@ merges @imp@ with an existing one if any.
+instance Unfoldable Imports ImportOp where
+ insert qi@(QualifiedImp {}) (Imports s) = Imports $ insert qi s
+ insert ui@(UnqualifiedImp {}) (Imports s)
+ = case find sameMod s of
+ Nothing → Imports $ insert ui s
+ Just ui' → Imports $ insert (merge ui') (delete ui' s)
+ where
+ sameMod ∷ ImportOp → Bool
+ sameMod ui'@(UnqualifiedImp {})
+ = impModule ui ≡ impModule ui'
+ sameMod _
+ = False
+
+ merge ∷ ImportOp → ImportOp
+ merge ui'
+ = case (impNames ui, impNames ui') of
+ (Nothing, _ ) → ui
+ (_ , Nothing ) → ui'
+ (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
+
+ empty = Imports empty
+ singleton = Imports ∘ singleton
+
+instance Monoid Imports where
+ mempty = empty
+ mappend = insertMany
+
instance Ord ImportOp where
α `compare` β
| impModule α < impModule β = LT
(UnqualifiedImp {}, _ )
→ LT
-instance Monoid (Imports ImportOp) where
- mempty
- = Imports (∅)
- mappend (Imports α) (Imports β)
- = Imports (foldl' insertImp α β)
-
-insertImp ∷ Set ImportOp → ImportOp → Set ImportOp
-insertImp α qi@(QualifiedImp {}) = S.insert qi α
-insertImp α ui@(UnqualifiedImp {})
- = case find sameMod α of
- Nothing → S.insert ui α
- Just ui' → S.insert (merge ui') (S.delete ui' α)
- where
- sameMod ∷ ImportOp → Bool
- sameMod ui'@(UnqualifiedImp {})
- = impModule ui ≡ impModule ui'
- sameMod _
- = False
-
- merge ∷ ImportOp → ImportOp
- merge ui'
- = case (impNames ui, impNames ui') of
- (Nothing, _ ) → ui
- (_ , Nothing) → ui'
- (Just s , Just s') → ui { impNames = Just (s ⊕ s') }
-
-- |@'qualifyAll' module alias@: qualify every symbols defined in
-- @module@ with @alias@.
qualifyAll ∷ String → String → RewriteRule
rop = Qualify (mkModName a)
iop = QualifiedImp (mkModName m) (mkModName a)
in
- RewriteRule pat rop (Imports (S.singleton iop))
+ RewriteRule pat rop (singleton iop)
-- |@'unqualify' name module@: unqualify the symbol @name@ with
-- importing @module@.
unqualify ∷ Name → String → RewriteRule
unqualify (Name o _) m
= let pat = NamePat Nothing (Just o)
- iop = UnqualifiedImp (mkModName m)
- $ Just
- $ S.singleton (VarName, o)
+ iop = UnqualifiedImp (mkModName m) ∘ Just
+ $ singleton (VarName, o)
in
- RewriteRule pat Unqualify (Imports (S.singleton iop))
+ RewriteRule pat Unqualify (singleton iop)
-- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
-- name, or whatever resides in the type or class @tycl@ with
unqualifyIn ∷ Name → Name → String → RewriteRule
unqualifyIn (Name name _) (Name tycl _) m
= let pat = NamePat Nothing (Just name)
- iop = UnqualifiedImp (mkModName m)
- $ Just
- $ S.singleton (TcClsName, tycl)
+ iop = UnqualifiedImp (mkModName m) ∘ Just
+ $ singleton (TcClsName, tycl)
in
- RewriteRule pat Unqualify (Imports (S.singleton iop))
+ RewriteRule pat Unqualify (singleton iop)
-- |@'unqualifyAll' origMod impMod@: unqualify every symbols
-- defined in @origMod@ with importing @impMod@.
= let pat = NamePat (Just (mkModName origMod)) Nothing
iop = UnqualifiedImp (mkModName impMod) Nothing
in
- RewriteRule pat Unqualify (Imports (S.singleton iop))
+ RewriteRule pat Unqualify (singleton iop)
-- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
-- in @d@ according to the name-rewriting @rules@ while at the same
-- time building a set of modules to be imported.
-rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp)
+rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports)
rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
where
- f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name
+ f ∷ (Functor m, Monad m) ⇒ Name → StateT Imports m Name
f n = case findRule rules n of
Nothing → fail $ "No rules matches to name: " ⧺ showName n
Just r → applyRule r n
applyRule ∷ (Functor m, Monad m)
⇒ RewriteRule
→ Name
- → StateT (Imports ImportOp) m Name
+ → StateT Imports m Name
applyRule (RewriteRule {..}) n
= modify (⊕ rrImps) *> pure (rewrite rrOp n)
projects / Lucu.git / blobdiff