+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+-- declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects tvs []
+ where
+ -- Collect all variables (2nd arg serves as an accumulator)
+ collect :: LHsType RdrName -> [LHsTyVarBndr RdrName]
+ -> P [LHsTyVarBndr RdrName]
+ collect (L l (HsForAllTy _ _ _ _)) =
+ const $ parseError l "Forall type not allowed as type parameter"
+ collect (L l (HsTyVar tv))
+ | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
+ | otherwise = return
+ collect (L l (HsBangTy _ _ )) =
+ const $ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsListTy t )) = collect t
+ collect (L _ (HsPArrTy t )) = collect t
+ collect (L _ (HsTupleTy _ ts )) = collects ts
+ collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsParTy t )) = collect t
+ collect (L _ (HsNumTy _ )) = return
+ collect (L l (HsPredTy _ )) =
+ const $ parseError l "Predicate not allowed as type parameter"
+ collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv =
+ return . (L l (KindedTyVar tv k) :)
+ | otherwise =
+ const $ parseError l "Kind signature only allowed for type variables"
+ collect (L l (HsSpliceTy _ )) =
+ const $ parseError l "Splice not allowed as type parameter"
+
+ -- Collect all variables of a list of types
+ collects [] = return
+ collects (t:ts) = collects ts >=> collect t
+
+ (f >=> g) x = f x >>= g
+
+-- Check that associated type declarations of a class are all kind signatures.
+--
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+ where
+ check (L l tydecl)
+ | isFamilyDecl tydecl
+ || isSynDecl tydecl = return ()
+ | otherwise =
+ parseError l "Type declaration in a class must be a kind signature or synonym default"
+