{-# LANGUAGE
FlexibleInstances
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, RecordWildCards
, UnicodeSyntax
#-}
, rewriteNames
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow
import Control.Monad.State
+import Data.Collections
+import Data.Collections.BaseInstances ()
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 Language.Haskell.TH.Syntax
-import Prelude
+import Prelude hiding (filter, foldr, lookup)
import Prelude.Unicode
-- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
| 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
}
+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') }
+
+instance Foldable Imports ImportOp where
+ foldr f b (Imports s) = foldr f b s
+
+instance Collection Imports ImportOp where
+ filter f (Imports s) = Imports $ filter f s
+
+instance Monoid Imports where
+ mempty = empty
+ mappend (Imports α) (Imports β)
+ = Imports $ insertManySorted β α
+
+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 α β
+
+instance Set Imports ImportOp where
+ haddock_candy = haddock_candy
+
+instance SortingCollection Imports ImportOp where
+ minView (Imports s) = second Imports <$> minView s
+
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@.
= let pat = NamePat Nothing (Just o)
iop = UnqualifiedImp (mkModName m)
$ Just
- $ S.singleton (VarName, o)
+ $ 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
= let pat = NamePat Nothing (Just name)
iop = UnqualifiedImp (mkModName m)
$ Just
- $ S.singleton (TcClsName, tycl)
+ $ 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