Commit 770e16fc authored by Simon Peyton Jones's avatar Simon Peyton Jones

In splitHsFunType, take account of prefix (->)

This fixes Trac #9096
parent 2745164a
......@@ -45,6 +45,7 @@ import HsLit
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
import TysPrim( funTyConName )
import Type
import HsDoc
import BasicTypes
......@@ -506,15 +507,31 @@ splitLHsClassTy_maybe ty
HsKindSig ty _ -> checkl ty args
_ -> Nothing
-- Splits HsType into the (init, last) parts
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
where
(args, res) = splitHsFunType y
splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty
splitHsFunType other = ([], other)
-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
-- (see Trac #9096)
splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
splitHsFunType (L _ (HsParTy ty))
= splitHsFunType ty
splitHsFunType (L _ (HsFunTy x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
= go t1 [t2]
where -- Look for (->) t1 t2, possibly with parenthesisation
go (L _ (HsTyVar fn)) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
go (L _ (HsParTy ty)) tys = go ty tys
go _ _ = ([], orig_ty) -- Failure to match
splitHsFunType other = ([], other)
\end{code}
......
{-# LANGUAGE GADTs #-}
module T9096 where
data Foo a where
MkFoo :: (->) a (Foo a)
......@@ -122,3 +122,4 @@ test('T7321',
['$MAKE -s --no-print-directory T7321'])
test('T7974', normal, compile, [''])
test('T7558', normal, compile_fail, [''])
test('T9096', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment