aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-08-28 15:24:05 -0700
committerAlec Theriault <alec.theriault@gmail.com>2018-11-05 15:54:22 -0800
commitd9c87e47afda04fd2bda380b81afca8e337a517c (patch)
tree5cf09ea2ee36f80f6a74c0bae46aa2901396e263 /haddock-api/src/Haddock
parent91c09e4bda60f89ff477aacf2f214da40a047065 (diff)
Improve perf of renaming
Perf only change: * don't look up type variable names (they're never in the environment) * use a difference list for accumulating missing names * more efficient 'Functor'/'Applicative' instances for 'RnM'
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs69
1 files changed, 33 insertions, 36 deletions
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e669ac50..42281470 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -26,12 +26,12 @@ import RdrName (RdrName(Exact))
import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
+import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
-
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
@@ -92,56 +92,53 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
--------------------------------------------------------------------------------
+-- | The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
+ RnM { unRn :: (Name -> (Bool, DocName))
+ -- Name lookup function. The 'Bool' indicates that if the name
+ -- was \"found\" in the environment.
+
+ -> (a, [Name] -> [Name])
+ -- Value returned, as well as a difference list of the names not
+ -- found
}
instance Monad RnM where
- (>>=) = thenRn
- return = pure
+ m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
+ (b, out2) = unRn (k a) lkp
+ in (b, out1 . out2)
instance Functor RnM where
- fmap f x = do a <- x; return (f a)
+ fmap f (RnM lkp) = RnM (first f . lkp)
instance Applicative RnM where
- pure = returnRn
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
+ pure a = RnM (const (a, id))
+ mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
+ (x, out2) = unRn mx lkp
+ in (f x, out1 . out2)
+-- | Look up a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
+lookupRn name = RnM $ \lkp ->
case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
+ (False,maps_to) -> (maps_to, (name :))
+ (True, maps_to) -> (maps_to, id)
+
+-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
+-- Returns the renamed value along with a list of `Name`'s that could not be
+-- renamed because they weren't in the environment.
+runRnFM :: LinkEnv -> RnM a -> (a, [Name])
+runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
+ lkp n | isTyVarName n = (True, Undocumented n)
+ | otherwise = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
--------------------------------------------------------------------------------