diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 28 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 46 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 65 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 43 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 406 |
6 files changed, 538 insertions, 51 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 86a9957c..faf043aa 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -33,14 +33,13 @@ import FamInstEnv import FastString import GHC import GhcMonad (withSession) -import Id import InstEnv import MonadUtils (liftIO) import Name import Outputable (text, sep, (<+>)) import PrelNames +import SrcLoc import TcRnDriver (tcRnGetInfo) -import TcType (tcSplitSigmaTy) import TyCon import TyCoRep import TysPrim( funTyCon ) @@ -69,25 +68,26 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, n) + let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) | i <- sortBy (comparing instFam) fam_instances - , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap , not $ isNameHidden expInfo (fi_fam i) , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text @@ -106,6 +106,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + -- spanName on Either + spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) + spanNameE s (Right ok) linst = + let L l r = spanName s ok linst + in L l (Right r) instLookup :: (InstalledInterface -> Map.Map Name a) -> Name diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7da965ac..c41946f5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,9 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Ast as Hyperlinker +import Haddock.Backends.Hyperlinker.Parser as Hyperlinker import qualified Data.Map as M import Data.Map (Map) @@ -124,6 +127,8 @@ createInterface tm flags modMap instIfaceMap = do mkAliasMap dflags $ tm_renamed_source tm modWarn = moduleWarning dflags gre warnings + tokenizedSrc <- mkMaybeTokenizedSrc flags tm + return $! Interface { ifaceMod = mdl , ifaceOrigFilename = msHsFilePath ms @@ -147,6 +152,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap + , ifaceTokenizedSrc = tokenizedSrc } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName @@ -519,7 +525,7 @@ mkExportItems case findDecl t of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -622,13 +628,19 @@ hiDecl dflags t = do O.text "-- Please report this on Haddock issue tracker!" bugWarn = O.showSDoc dflags . warnLine -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc splice fixity = do +-- | This function is called for top-level bindings without type signatures. +-- It gets the type signature from GHC and that means it's not going to +-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the +-- declaration and use it instead - 'nLoc' here. +hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) where + fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -739,7 +751,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) + fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = @@ -842,6 +854,30 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs +mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule + -> ErrMsgGhc (Maybe [RichToken]) +mkMaybeTokenizedSrc flags tm + | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of + Just src -> do + tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src + return $ Just tokens + Nothing -> do + liftErrMsg . tell . pure $ concat + [ "Warning: Cannot hyperlink module \"" + , moduleNameString . ms_mod_name $ summary + , "\" because renamed source is not available" + ] + return Nothing + | otherwise = return Nothing + where + summary = pm_mod_summary . tm_parsed_module $ tm + +mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] +mkTokenizedSrc ms src = + Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc + where + rawSrc = readFile $ msHsFilePath ms + -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 9c46c700..3c14498c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) @@ -30,9 +29,9 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import RdrHsSyn ( setRdrNameSpace ) import Outputable ( showPpr ) import RdrName +import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (MDoc Name) @@ -76,7 +75,13 @@ processModuleHeader dflags gre safety mayStr = do where failure = (emptyHaddockModInfo, Nothing) - +-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the +-- definitions and a parsed comment and we attempt to make sense of +-- where the identifiers in the comment point to. We're in effect +-- trying to convert 'RdrName's to 'Name's, with some guesswork and +-- fallbacks in case we can't locate the identifiers. +-- +-- See the comments in the source for implementation commentary. rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name rename dflags gre = rn where @@ -84,19 +89,36 @@ rename dflags gre = rn DocAppend a b -> DocAppend (rn a) (rn b) DocParagraph doc -> DocParagraph (rn doc) DocIdentifier x -> do - let choices = dataTcOccs' x + -- Generate the choices for the possible kind of thing this + -- is. + let choices = dataTcOccs x + -- Try to look up all the names in the GlobalRdrEnv that match + -- the names. let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + -- We found no names in the env so we start guessing. [] -> case choices of [] -> DocMonospaced (DocString (showPpr dflags x)) - [a] -> outOfScope dflags a - a:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b + -- There was nothing in the environment so we need to + -- pick some default from what's available to us. We + -- diverge here from the old way where we would default + -- to type constructors as we're much more likely to + -- actually want anchors to regular definitions than + -- type constructor names (such as in #253). So now we + -- only get type constructor links if they are actually + -- in scope. + a:_ -> outOfScope dflags a + + -- There is only one name in the environment that matches so + -- use it. [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. + -- But when there are multiple names available, default to + -- type constructors: somewhat awfully GHC returns the + -- values in the list positionally. + a:b:_ | isTyConName a -> DocIdentifier a + | otherwise -> DocIdentifier b DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) @@ -117,21 +139,14 @@ rename dflags gre = rn DocString str -> DocString str DocHeader (Header l t) -> DocHeader $ Header l (rn t) -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - +-- | Wrap an identifier that's out of scope (i.e. wasn't found in +-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently +-- we simply monospace the identifier in most cases except when the +-- identifier is qualified: if the identifier is qualified then we can +-- still try to guess and generate anchors accross modules but the +-- users shouldn't rely on this doing the right thing. See tickets +-- #253 and #375 on the confusion this causes depending on which +-- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a outOfScope dflags x = case x of diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index d92e8b2a..e7d2a085 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Applicative ((<$>)) import Control.Monad (mplus) import Data.Char import DynFlags diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 091d9bff..2478ce23 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -12,7 +13,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse, Traversable) +import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types @@ -25,7 +26,6 @@ import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Data.Traversable (mapM) import Prelude hiding (mapM) @@ -287,16 +287,24 @@ renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename na renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (className, k, types, rest) = do - className' <- rename className - k' <- mapM renameType k - types' <- mapM renameType types - rest' <- case rest of - ClassInst cs -> ClassInst <$> mapM renameType cs +renameInstHead InstHead {..} = do + cname <- rename ihdClsName + kinds <- mapM renameType ihdKinds + types <- mapM renameType ihdTypes + itype <- case ihdInstType of + ClassInst { .. } -> ClassInst + <$> mapM renameType clsiCtx + <*> renameLHsQTyVars clsiTyVars + <*> mapM renameSig clsiSigs + <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd - return (className', k', types', rest') - + return InstHead + { ihdClsName = cname + , ihdKinds = kinds + , ihdTypes = types + , ihdInstType = itype + } renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d @@ -375,6 +383,16 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars', fdResultSig = result' , fdInjectivityAnn = injectivity' }) + +renamePseudoFamilyDecl :: PseudoFamilyDecl Name + -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl + <$> renameFamilyInfo pfdInfo + <*> renameL pfdLName + <*> mapM renameLType pfdTyVars + <*> renameFamilyResultSig pfdKindSig + + renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily @@ -553,10 +571,11 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc) -> do + instances' <- forM instances $ \(inst, idoc, L l n) -> do inst' <- renameInstHead inst + n' <- rename n idoc' <- mapM renameDoc idoc - return (inst', idoc') + return (inst', idoc',L l n') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs new file mode 100644 index 00000000..ab719fe8 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Interface.Specialize + ( specializeInstHead + ) where + + +import Haddock.Syb +import Haddock.Types + +import GHC +import Name +import FastString + +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +import Data.Data +import qualified Data.List as List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +-- | Instantiate all occurrences of given name with particular type. +specialize :: (Eq name, Typeable name) + => Data a + => name -> HsType name -> a -> a +specialize name details = + everywhere $ mkT step + where + step (HsTyVar (L _ name')) | name == name' = details + step typ = typ + + +-- | Instantiate all occurrences of given names with corresponding types. +-- +-- It is just a convenience function wrapping 'specialize' that supports more +-- that one specialization. +specialize' :: (Eq name, Typeable name) + => Data a + => [(name, HsType name)] -> a -> a +specialize' = flip $ foldr (uncurry specialize) + + +-- | Instantiate given binders with corresponding types. +-- +-- Again, it is just a convenience function around 'specialize'. Note that +-- length of type list should be the same as the number of binders. +specializeTyVarBndrs :: (Eq name, DataId name) + => Data a + => LHsQTyVars name -> [HsType name] + -> a -> a +specializeTyVarBndrs bndrs typs = + specialize' $ zip bndrs' typs + where + bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs + bname (UserTyVar (L _ name)) = name + bname (KindedTyVar (L _ name) _) = name + + +specializePseudoFamilyDecl :: (Eq name, DataId name) + => LHsQTyVars name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name +specializePseudoFamilyDecl bndrs typs decl = + decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } + where + specializeTyVars = specializeTyVarBndrs bndrs typs + + +specializeSig :: forall name . (Eq name, DataId name, SetName name) + => LHsQTyVars name -> [HsType name] + -> Sig name + -> Sig name +specializeSig bndrs typs (TypeSig lnames typ) = + TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) + where + true_type :: HsType name + true_type = unLoc (hswc_body (hsib_body typ)) + typ' :: HsType name + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type + fv = foldr Set.union Set.empty . map freeVariables $ typs +specializeSig _ _ sig = sig + + +-- | Make all details of instance head (signatures, associated types) +-- specialized to that particular instance type. +specializeInstHead :: (Eq name, DataId name, SetName name) + => InstHead name -> InstHead name +specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = + ihd { ihdInstType = instType' } + where + instType' = clsi + { clsiSigs = map specializeSig' clsiSigs + , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys + } + specializeSig' = specializeSig clsiTyVars ihdTypes + specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes +specializeInstHead ihd = ihd + + +-- | Make given type use tuple and list literals where appropriate. +-- +-- After applying 'specialize' function some terms may not use idiomatic list +-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This +-- can be fixed using 'sugar' function, that will turn such types into @[a]@ +-- and @(a, b, c)@. +sugar :: forall name. (NamedThing name, DataId name) + => HsType name -> HsType name +sugar = + everywhere $ mkT step + where + step :: HsType name -> HsType name + step = sugarOperators . sugarTuples . sugarLists + + +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp + where + name' = getName name + strName = occNameString . nameOccName $ name' +sugarLists typ = typ + + +sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples typ = + aux [] typ + where + aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy (L _ typ')) = aux apps typ' + aux apps (HsTyVar (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + where + name' = getName name + strName = occNameString . nameOccName $ name' + suitable = case parseTupleArity strName of + Just arity -> arity == length apps + Nothing -> False + aux _ _ = typ + + +sugarOperators :: NamedThing name => HsType name -> HsType name +sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb) + | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + where + name' = getName name +sugarOperators typ = typ + + +-- | Compute arity of given tuple operator. +-- +-- >>> parseTupleArity "(,,)" +-- Just 3 +-- +-- >>> parseTupleArity "(,,,,)" +-- Just 5 +-- +-- >>> parseTupleArity "abc" +-- Nothing +-- +-- >>> parseTupleArity "()" +-- Nothing +parseTupleArity :: String -> Maybe Int +parseTupleArity ('(':commas) = do + n <- parseCommas commas + guard $ n /= 0 + return $ n + 1 + where + parseCommas (',':rest) = (+ 1) <$> parseCommas rest + parseCommas ")" = Just 0 + parseCommas _ = Nothing +parseTupleArity _ = Nothing + + +-- | Haskell AST type representation. +-- +-- This type is used for renaming (more below), essentially the ambiguous (!) +-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, +-- it was 'OccName' before, but turned out that 'OccName' sometimes also +-- contains namespace information, differentiating visually same types. +-- +-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is +-- not converted to 'String' or alike to avoid new allocations. Additionally, +-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also +-- quite nice. +type NameRep = FastString + +getNameRep :: NamedThing name => name -> NameRep +getNameRep = occNameFS . getOccName + +nameRepString :: NameRep -> String +nameRepString = unpackFS + +stringNameRep :: String -> NameRep +stringNameRep = mkFastString + +setInternalNameRep :: SetName name => NameRep -> name -> name +setInternalNameRep = setInternalOccName . mkVarOccFS + +setInternalOccName :: SetName name => OccName -> name -> name +setInternalOccName occ name = + setName nname' name + where + nname = getName name + nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) + + +-- | Compute set of free variables of given type. +freeVariables :: forall name. (NamedThing name, DataId name) + => HsType name -> Set NameRep +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy bndrs _) -> + (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsTyVar (L _ name)) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getNameRep name, ctx) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + + +-- | Make given type visually unambiguous. +-- +-- After applying 'specialize' method, some free type variables may become +-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to +-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to +-- different type variable than latter one. Applying 'rename' function +-- will fix that type to be visually unambiguous again (making it something +-- like @(a -> c) -> b@). +rename :: SetName name => Set NameRep -> HsType name -> HsType name +rename fv typ = runReader (renameType typ) $ RenameEnv + { rneFV = fv + , rneCtx = Map.empty + } + + +-- | Renaming monad. +type Rename name = Reader (RenameEnv name) + +-- | Binding generation monad. +type Rebind name = State (RenameEnv name) + +data RenameEnv name = RenameEnv + { rneFV :: Set NameRep + , rneCtx :: Map Name name + } + + +renameType :: SetName name => HsType name -> Rename name (HsType name) +renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> + HsForAllTy + <$> pure bndrs' + <*> renameLType lt +renameType (HsQualTy lctxt lt) = + HsQualTy + <$> located renameContext lctxt + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> located renameName name +renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la +renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr +renameType (HsListTy lt) = HsListTy <$> renameLType lt +renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt +renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt +renameType (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy lt) = HsParTy <$> renameLType lt +renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt +renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb +renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType t@(HsSpliceTy _ _) = pure t +renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc +renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt +renameType t@(HsRecTy _) = pure t +renameType t@(HsCoreTy _) = pure t +renameType (HsExplicitListTy ph ltys) = + HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> renameLTypes ltys +renameType t@(HsTyLit _) = pure t +renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" + + +renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType = located renameType + + +renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes = mapM renameLType + + +renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext = renameLTypes + +{- +renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname +-} + + +renameName :: SetName name => name -> Rename name name +renameName name = do + RenameEnv { rneCtx = ctx } <- ask + pure $ fromMaybe name (Map.lookup (getName name) ctx) + + +rebind :: SetName name + => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) + -> Rename name a +rebind lbndrs action = do + (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask + local (const env') (action lbndrs') + + +rebindLTyVarBndrs :: SetName name + => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] +rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs + + +rebindTyVarBndr :: SetName name + => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) +rebindTyVarBndr (UserTyVar (L l name)) = + UserTyVar . L l <$> rebindName name +rebindTyVarBndr (KindedTyVar name kinds) = + KindedTyVar <$> located rebindName name <*> pure kinds + + +rebindName :: SetName name => name -> Rebind name name +rebindName name = do + RenameEnv { .. } <- get + taken <- takenNames + case Map.lookup (getName name) rneCtx of + Just name' -> pure name' + Nothing | getNameRep name `Set.member` taken -> freshName name + Nothing -> reuseName name + + +-- | Generate fresh occurrence name, put it into context and return. +freshName :: SetName name => name -> Rebind name name +freshName name = do + env@RenameEnv { .. } <- get + taken <- takenNames + let name' = setInternalNameRep (findFreshName taken rep) name + put $ env { rneCtx = Map.insert nname name' rneCtx } + return name' + where + nname = getName name + rep = getNameRep nname + + +reuseName :: SetName name => name -> Rebind name name +reuseName name = do + env@RenameEnv { .. } <- get + put $ env { rneCtx = Map.insert (getName name) name rneCtx } + return name + + +takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames = do + RenameEnv { .. } <- get + return $ Set.union rneFV (ctxElems rneCtx) + where + ctxElems = Set.fromList . map getNameRep . Map.elems + + +findFreshName :: Set NameRep -> NameRep -> NameRep +findFreshName taken = + fromJust . List.find isFresh . alternativeNames + where + isFresh = not . flip Set.member taken + + +alternativeNames :: NameRep -> [NameRep] +alternativeNames name + | [_] <- nameRepString name = letterNames ++ alternativeNames' name + where + letterNames = map (stringNameRep . pure) ['a'..'z'] +alternativeNames name = alternativeNames' name + + +alternativeNames' :: NameRep -> [NameRep] +alternativeNames' name = + [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] + where + str = nameRepString name + + +located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr name -> name +tyVarName (UserTyVar name) = unLoc name +tyVarName (KindedTyVar (L _ name) _) = name |