Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
770e16fc
Commit
770e16fc
authored
May 12, 2014
by
Simon Peyton Jones
Browse files
In splitHsFunType, take account of prefix (->)
This fixes Trac
#9096
parent
2745164a
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/hsSyn/HsTypes.lhs
View file @
770e16fc
...
...
@@ -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
--
S
plit
s HsType into the (init, last) parts
--
s
plit
HsFunType 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}
...
...
testsuite/tests/gadt/T9096.hs
0 → 100644
View file @
770e16fc
{-# LANGUAGE GADTs #-}
module
T9096
where
data
Foo
a
where
MkFoo
::
(
->
)
a
(
Foo
a
)
testsuite/tests/gadt/all.T
View file @
770e16fc
...
...
@@ -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
,
[''])
Administrator
@root
mentioned in commit
16622452
·
Dec 17, 2018
mentioned in commit
16622452
mentioned in commit 16622452317fe235afc2a053686f46b7d30733a2
Toggle commit list
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment