, 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(..)
)
where
import Control.Applicative hiding (empty)
-import Control.Arrow
import Control.Monad.State
import Data.Collections
import Data.Collections.BaseInstances ()
+import qualified Data.Collections.Newtype.TH as C
import Data.Data
import Data.Generics.Aliases hiding (GT)
import Data.Generics.Schemes
import Data.Monoid.Unicode
import qualified Data.Set as S (Set)
import Language.Haskell.TH.Syntax
-import Prelude hiding (filter, foldr, lookup)
+import Prelude
import Prelude.Unicode
-- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
, 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
empty = Imports empty
singleton = Imports ∘ singleton
--- FIXME: auto-derive
-instance Foldable Imports ImportOp where
- foldr f b (Imports s) = foldr f b s
-
--- FIXME: auto-derive
-instance Collection Imports ImportOp where
- filter f (Imports s) = Imports $ filter f s
-
instance Monoid Imports where
mempty = empty
mappend = insertMany
--- FIXME: auto-derive
-instance Map Imports ImportOp () where
- lookup k (Imports s) = lookup k s
- mapWithKey f (Imports m)
- = Imports $ mapWithKey f m
- unionWith f (Imports α) (Imports β)
- = Imports $ unionWith f α β
- intersectionWith f (Imports α) (Imports β)
- = Imports $ intersectionWith f α β
- differenceWith f (Imports α) (Imports β)
- = Imports $ differenceWith f α β
- isSubmapBy f (Imports α) (Imports β)
- = isSubmapBy f α β
- isProperSubmapBy f (Imports α) (Imports β)
- = isProperSubmapBy f α β
-
--- FIXME: auto-derive
-instance Set Imports ImportOp where
- haddock_candy = haddock_candy
-
--- FIXME: auto-derive
-instance SortingCollection Imports ImportOp where
- minView (Imports s) = second Imports <$> minView s
-
instance Ord ImportOp where
α `compare` β
| impModule α < impModule β = LT
unqualify ∷ Name → String → RewriteRule
unqualify (Name o _) m
= let pat = NamePat Nothing (Just o)
- iop = UnqualifiedImp (mkModName m)
- $ Just
+ iop = UnqualifiedImp (mkModName m) ∘ Just
$ singleton (VarName, o)
in
RewriteRule pat Unqualify (singleton iop)
unqualifyIn ∷ Name → Name → String → RewriteRule
unqualifyIn (Name name _) (Name tycl _) m
= let pat = NamePat Nothing (Just name)
- iop = UnqualifiedImp (mkModName m)
- $ Just
+ iop = UnqualifiedImp (mkModName m) ∘ Just
$ singleton (TcClsName, tycl)
in
RewriteRule pat Unqualify (singleton iop)