aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-19 20:30:06 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit77b628b79bd179e7dde83d44bbea5acb4c0cb043 (patch)
treeaaa650adc39ac58c6bf6bfe6e0c36a9a4716b3c5
parentd5700e1427f7171db0e0e9393aedb734b554459f (diff)
Create function for retrieving free variables from given type.
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs20
1 files changed, 20 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 6a149719..7e568933 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -159,6 +159,21 @@ renameType HsWildcardTy = pure HsWildcardTy
renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
+freeVariables :: forall name. (NamedThing name, Data (HsType name))
+ => HsType name -> Set OccName
+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 name)
+ | getName name `Set.member` ctx -> (Set.empty, ctx)
+ | otherwise -> (Set.singleton $ getOccName name, ctx)
+ _ -> (Set.empty, ctx)
+ bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+
+
renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
renameLType = located renameType
@@ -237,3 +252,8 @@ alternativeNames 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) = name
+tyVarName (KindedTyVar (L _ name) _) = name