[darcs-devel] [issue197] Another darcs crash
simonpj
bugs at darcs.net
Mon Jul 3 13:23:11 PDT 2006
New submission from simonpj <simonpj at microsoft.com>:
OK. To reproduce the bug below, upload
http://research.microsoft.com/~simonpj/tmp/fc-branch-new.zip
and try to do
darcs pull -p 'the unlifted kind'
Pulling just this one patch elicits the bug.
Simon
around it.
|
| darcs.exe: bug in darcs!
| in function reconcile_unwindings
| Original patch:
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 230
| ....
|
| Full story below
|
|
| Simon
|
|
| darcs --exact-version
| darcs compiled on May 14 2006, at 15:38:56
| # configured Sun May 14 15:29:40 USMST 2006
| ./configure --disable-mmap
|
| Context:
|
| [TAG 1.0.7
| Tommy Pettersson <ptp at lysator.liu.se>**20060513171438]
| sh-2.04$
|
|
| darcs pull -av
| Usage: ssh [options] host [command]
| Options:
| -l user Log in using this user name.
| -n Redirect input from /dev/null.
| -A Enable authentication agent forwarding.
| -a Disable authentication agent forwarding.
| -X Enable X11 connection forwarding.
| -x Disable X11 connection forwarding.
| -i file Identity for public key authentication (default:
~/.ssh/identity)
| -t Tty; allocate a tty even if command is given.
| -T Do not allocate a tty.
| -v Verbose; display verbose debugging messages.
| Multiple -v increases verbosity.
| -V Display version number only.
| -P Don't allocate a privileged port.
| -q Quiet; don't display any warning messages.
| -f Fork into background after authentication.
| -e char Set escape character; ``none'' = disable (default: ~).
| -c cipher Select encryption algorithm: ``3des'', ``blowfish''
| -m macs Specify MAC algorithms for protocol version 2.
| -p port Connect to this port. Server must be on the same port.
| -L listen-port:host:port Forward local port to remote address
| -R listen-port:host:port Forward remote port to local address
| These cause ssh to listen for connections on a port, and
| forward them to the other side by connecting to
host:port.
| -C Enable compression.
| -N Do not execute a shell or command.
| -g Allow remote hosts to connect to forwarded ports.
| -1 Force protocol version 1.
| -2 Force protocol version 2.
| -4 Use IPv4 only.
| -6 Use IPv6 only.
| -o 'option' Process the option as if it was read from a
configuration file.
| -s Invoke command (mandatory) as SSH2 subsystem.
| Pulling from "http://darcs.haskell.org/ghc"...
| This is the GHC darcs repostory (HEAD branch)
|
| For more information, visit the GHC developer wiki at
| http://hackage.haskell.org/trac/ghc
| **********************
| We have the following new (to them) patches:
| Fri Jun 30 13:13:08 GMT Daylight Time 2006 simonpj at microsoft.com
| * Tidy up selector generation code; no change in behaviour
| Fri Jun 30 11:19:02 GMT Daylight Time 2006 kevind at bu.edu
| * fixes for reconstructing newtypes
| Thu Jun 29 15:57:58 GMT Daylight Time 2006 simonpj at microsoft.com
| * Half-baked fix to unpacking code
| Thu Jun 29 14:56:57 GMT Daylight Time 2006 kevind at bu.edu
| * sym coercion smart constructors, removed debugging outputs
| Thu Jun 29 11:39:21 GMT Daylight Time 2006 kevind at bu.edu
| * Flip coercionKind and coercionKindPair
| Thu Jun 29 11:05:16 GMT Daylight Time 2006 kevind at bu.edu
| * reboxing bug traces
| Wed Jun 28 17:45:54 GMT Daylight Time 2006 simonpj at microsoft.com
| * Make sure that nt_rhs uses the *tycon* tyvars
| Wed Jun 28 13:38:15 GMT Daylight Time 2006 simonpj at microsoft.com
| * Wibbles, esp getting CoTyCon into the implicitTyThings of a
newtype
| Wed Jun 28 11:47:23 GMT Daylight Time 2006 kevind at bu.edu
| * bug fix
| Tue Jun 27 11:59:09 GMT Daylight Time 2006 kevind at bu.edu
| * stop simplifier from throwing out newtype coercions
| Tue Jun 27 11:16:22 GMT Daylight Time 2006 kevind at bu.edu
| * fixed a few bugs, put coercions for all newtypes, killed some
assertions that things are recursive
| newtypes
| Thu Jun 22 15:14:55 GMT Daylight Time 2006 kevind at bu.edu
| * some refactoring with decomposeCo
| Thu Jun 22 15:00:42 GMT Daylight Time 2006 kevind at bu.edu
| * fix core lint for let bindings
| Thu Jun 22 12:00:27 GMT Daylight Time 2006 simonpj at microsoft.com
| * Fix Linting of type applications, and add coments
| Thu Jun 22 11:20:00 GMT Daylight Time 2006 kevind at bu.edu
| * Linting going wrong
| Wed Jun 21 17:47:00 GMT Daylight Time 2006 kevind at bu.edu
| * corelint fixes, still some type substitution strangeness
| Wed Jun 21 13:48:51 GMT Daylight Time 2006 kevind at bu.edu
| * Substitution in binder types/kinds in CoreLint
| Tue Jun 20 14:50:53 GMT Daylight Time 2006 kevind at bu.edu
| * minor changes
| Mon Jun 19 16:04:21 GMT Daylight Time 2006 kevind at bu.edu
| * Squashed a couple more
| Wed Jun 21 09:36:55 GMT Daylight Time 2006 simonpj at microsoft.com
| * Add missing TcGadt.lhs
| Wed Jun 21 09:34:44 GMT Daylight Time 2006 simonpj at microsoft.com
| * Remove compiler from the boring list (how did it get there?)
| Wed Jun 21 08:51:54 GMT Daylight Time 2006 simonpj at microsoft.com
| * Missing imports
| Tue Jun 20 15:35:56 GMT Daylight Time 2006 simonpj at microsoft.com
| * Take 2: Use FC for GADTs, for the first time
|
| (The "take 2" part refers to the fact that I got
| into a terrible mess with a Darcs bug the first time
| round. That patch is not in the repository at all now.)
|
| This commit deals with equality-evidence generation for GADTs.
| It touches a lot of files. It probably doesn't work 100%
| yet, but it compiles ok.
|
| The biggest changes are to the type inference engine, which
| must now generate equality evidence when doing GADT type
| refinement.
|
| In the rest of the compiler, data contructors are now
| treated uniformly (instead of have a special case for
| vanilla data cons). Furthermore, we can remove all the
| type-refinement code from the optimisation passes.
| Hooray!
| Tue Jun 20 15:18:44 GMT Daylight Time 2006 simonpj at microsoft.com
| * Conflict resolution
| Mon Jun 19 13:26:37 GMT Daylight Time 2006 simonpj at microsoft.com
| * Substitutions, plus numerous small things
| Fri Jun 16 16:04:19 GMT Daylight Time 2006 kevind at bu.edu
| * badness here
| Fri Jun 16 10:35:48 GMT Daylight Time 2006 kevind at bu.edu
| * fixes
| Thu Jun 15 16:12:31 GMT Daylight Time 2006 kevind at bu.edu
| * now it compiles (some) libraries
| Thu Jun 15 15:48:37 GMT Daylight Time 2006 kevind at bu.edu
| * More wibbles
| Thu Jun 15 14:33:46 GMT Daylight Time 2006 kevind at bu.edu
| * fixes
| Thu Jun 15 11:14:59 GMT Daylight Time 2006 simonpj at microsoft.com
| * Wibbles
| Thu Jun 15 10:50:36 GMT Daylight Time 2006 kevind at bu.edu
| * compiling
| Thu Jun 15 10:34:27 GMT Daylight Time 2006 kevind at bu.edu
| * adding stubs
| Wed Jun 14 16:13:25 GMT Daylight Time 2006 kevind at bu.edu
| * some changes
| Wed Jun 14 15:52:32 GMT Daylight Time 2006 kevind at bu.edu
| * Fixed BuildTyCls, not compiling yet
| Wed Jun 14 10:22:13 GMT Daylight Time 2006 simonpj at microsoft.com
| * Steps towards mkNewTyConRhs
| Thu Jun 8 18:05:32 GMT Daylight Time 2006 kevind at bu.edu
| * little things
| Thu Jun 8 16:02:43 GMT Daylight Time 2006 simonpj at microsoft.com
| * Minor changes
| Thu Jun 8 15:42:42 GMT Daylight Time 2006 kevind at bu.edu
| * newtype stuff
| Thu Jun 8 15:12:12 GMT Daylight Time 2006 simonpj at microsoft.com
| * more from simion
| Thu Jun 8 13:28:05 GMT Daylight Time 2006 simonpj at microsoft.com
| * First steps towards GADTs with FC
| Thu Jun 8 11:42:05 GMT Daylight Time 2006 simonpj at microsoft.com
| * nt_co is a TyCOn now
| Thu Jun 8 11:40:31 GMT Daylight Time 2006 simonpj at microsoft.com
| * Comments only
| Thu Jun 8 10:44:33 GMT Daylight Time 2006 simonpj at microsoft.com
| * Comments only
| Thu Jun 8 10:17:24 GMT Daylight Time 2006 kevind at bu.edu
| * removed some commented out Coerce code, fixed a bug swapping
direction of coercion
| Wed Jun 7 17:21:08 GMT Daylight Time 2006 kevind at bu.edu
| * external core fix
| Wed Jun 7 16:44:26 GMT Daylight Time 2006 kevind at bu.edu
| * It's Alive!
| Wed Jun 7 15:54:37 GMT Daylight Time 2006 kevind at bu.edu
| * towards compiling
| Wed Jun 7 12:45:50 GMT Daylight Time 2006 simonpj at microsoft.com
| * Comments
| Wed Jun 7 12:30:52 GMT Daylight Time 2006 simonpj at microsoft.com
| * Stuff from Simon: EqPred, plus hole_ty in SimplUtils
| Wed Jun 7 11:36:00 GMT Daylight Time 2006 kevind at bu.edu
| * more
| Tue Jun 6 16:20:15 GMT Daylight Time 2006 simonpj at microsoft.com
| * simon and kevin discussion
| Tue Jun 6 15:40:17 GMT Daylight Time 2006 kevind at bu.edu
| * more cast
| Mon Jun 5 10:48:46 GMT Daylight Time 2006 simonpj at microsoft.com
| * Minor edits (Kevin and Simon together)
| Mon Jun 5 09:21:13 GMT Daylight Time 2006 kevind at bu.edu
| * coercions in, adding cast
| Fri May 26 13:55:28 GMT Daylight Time 2006 simonpj at microsoft.com
| * Fix typeKind silliness
| Thu May 25 13:57:21 GMT Daylight Time 2006 simonpj at microsoft.com
| * coercionTyCon[D[D[D[D[D[D[D[D[D[D[D[C
| Wed May 24 18:02:34 GMT Daylight Time 2006 kevind at bu.edu
| * Fixed typeKind to work right for kinds
| Wed May 24 17:10:39 GMT Daylight Time 2006 kevind at bu.edu
| * Some fixes, still won't compile library
| Tue May 23 13:21:17 GMT Daylight Time 2006 kevind at bu.edu
| * Kinds are Types, and things compile
| Tue May 23 10:08:22 GMT Daylight Time 2006 kevind at bu.edu
| * test
| Tue May 23 09:58:02 GMT Daylight Time 2006 kevind at bu.edu
| * Closer
| Mon May 22 16:43:31 GMT Daylight Time 2006 simonpj at microsoft.com
| * minor changes
| Mon May 22 15:11:37 GMT Daylight Time 2006 kevind at bu.edu
| * Kinds are now Types (may not yet compile, but close)
| Fri May 19 16:05:19 GMT Daylight Time 2006 simonpj at microsoft.com
| * Result of Simon/Kevin discussion
| Fri May 19 15:07:23 GMT Daylight Time 2006 kevind at bu.edu
| * Kind preliminarily Typified, doesn't compile yet
| Thu May 18 12:49:31 GMT Daylight Time 2006 kevind at bu.edu
| * KindTyCon's added
| They have the following patches to pull:
| Thu Jun 29 15:06:08 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * x86-64: fix a problem exposed by negative offsets in vector tables
| static relative offsets (eg .long l1-l2) are restricted to 32 bits
on
| x86-64 due to lack of support in the linker. The codegen, NCG and
| runtime work around this, using 32-bit offsets instead of 64.
| However, we were missing a workaround for vector tables, and it
| happened to work by accident because the offsets were always
positive
| and resolved by the assembler. The bug was exposed by using the NCG
| to compile the RTS, where the offsets became negative, again by
| accident.
| Thu Jun 29 14:58:36 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * No longer force -fvia-C for the RTS, it can now be compiled with
the NCG
| Thu Jun 29 14:47:26 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * Replace inline C functions with C-- macros in .cmm code
| So that we can build the RTS with the NCG.
| Thu Jun 29 14:44:05 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * remove conditionals from definition of StgRegTable
| so that we can calculate deterministic offsets to some of the fields
| of Capability.
| Thu Jun 29 13:22:17 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * mpz_foo() functions are really called __gmpz_foo() in GMP
| gmp.h #defines mpz_foo to __gmpz_foo, so the real ABI is __gmpz_foo,
| so that is what we must invoke in order to be portable here.
| Similarly for mpn --> __gmpn.
| Thu Jun 29 13:05:26 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * use the new "prim %write_barrier()" in .cmm instead of calls to
wb()
| Thu Jun 29 13:02:10 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * fix some problems with the fixup block code
| We weren't handling InBoth properly. InBoth needs to be expanded to
| appropriate InReg/InMem locations *before* building the interference
| graph, otherwise an InBoth will not be seen to conflict with other
| InReg/InMem locations.
| Thu Jun 29 13:00:29 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * small optimisation: eliminate more register-to-register moves
| Thu Jun 29 12:59:49 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * new syntax: "prim %OP (args)" for using CallishMachOps in .cmm
|
|
| Thu Jun 29 12:58:37 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * add MO_WriteBarrier to CallishMachOps
| This will let us express write barriers in C--
| Thu Jun 29 09:29:02 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * Use -fno-strict-aliasing for *all* C files in the runtime
| as a precautionary measure. It is definitely required for GC.c,
| but it may well become necessary for other files in the future due
to
| our (mis-)use of the C "type system".
| Fri Jun 23 16:26:26 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * the unlifted kind
| Tue Jun 20 16:19:01 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * fix a lint-o
| Tue Jun 20 16:17:58 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * fix sloppy conditionals
| Tue Jun 20 16:10:39 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * fix sloppy conditionals
| Tue Jun 20 16:06:18 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * fix a few sloppy conditionals caught by new test in CmmLint
| Tue Jun 20 16:05:20 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * flattenCgStmts: fix a case of empty code blocks being generated
| Tue Jun 20 15:12:19 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * improve a panic message
| Tue Jun 20 15:12:04 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * check that the argument to CmmCondBranch is really a conditional
| Tue Jun 20 15:01:06 GMT Daylight Time 2006 Simon Marlow
<simonmar at microsoft.com>
| * Generate a new unique for each label
| Getting and merging the following patches:
| [Generate a new unique for each label
| Simon Marlow <simonmar at microsoft.com>**20060620140106]
| [check that the argument to CmmCondBranch is really a conditional
| Simon Marlow <simonmar at microsoft.com>**20060620141204]
| [improve a panic message
| Simon Marlow <simonmar at microsoft.com>**20060620141219]
| [flattenCgStmts: fix a case of empty code blocks being generated
| Simon Marlow <simonmar at microsoft.com>**20060620150520]
| [fix a few sloppy conditionals caught by new test in CmmLint
| Simon Marlow <simonmar at microsoft.com>**20060620150618]
| [fix sloppy conditionals
| Simon Marlow <simonmar at microsoft.com>**20060620151039]
| [fix sloppy conditionals
| Simon Marlow <simonmar at microsoft.com>**20060620151758]
| [fix a lint-o
| Simon Marlow <simonmar at microsoft.com>**20060620151901]
| [the unlifted kind
| Simon Marlow <simonmar at microsoft.com>**20060623152626]
| [Use -fno-strict-aliasing for *all* C files in the runtime
| Simon Marlow <simonmar at microsoft.com>**20060629082902
| as a precautionary measure. It is definitely required for GC.c,
| but it may well become necessary for other files in the future due to
| our (mis-)use of the C "type system".
| ]
| [add MO_WriteBarrier to CallishMachOps
| Simon Marlow <simonmar at microsoft.com>**20060629115837
| This will let us express write barriers in C--
| ]
| [new syntax: "prim %OP (args)" for using CallishMachOps in .cmm
| Simon Marlow <simonmar at microsoft.com>**20060629115949
|
|
| ]
| [small optimisation: eliminate more register-to-register moves
| Simon Marlow <simonmar at microsoft.com>**20060629120029]
| [fix some problems with the fixup block code
| Simon Marlow <simonmar at microsoft.com>**20060629120210
| We weren't handling InBoth properly. InBoth needs to be expanded to
| appropriate InReg/InMem locations *before* building the interference
| graph, otherwise an InBoth will not be seen to conflict with other
| InReg/InMem locations.
| ]
| [use the new "prim %write_barrier()" in .cmm instead of calls to wb()
| Simon Marlow <simonmar at microsoft.com>**20060629120526]
| [mpz_foo() functions are really called __gmpz_foo() in GMP
| Simon Marlow <simonmar at microsoft.com>**20060629122217
| gmp.h #defines mpz_foo to __gmpz_foo, so the real ABI is __gmpz_foo,
| so that is what we must invoke in order to be portable here.
| Similarly for mpn --> __gmpn.
| ]
| [remove conditionals from definition of StgRegTable
| Simon Marlow <simonmar at microsoft.com>**20060629134405
| so that we can calculate deterministic offsets to some of the fields
| of Capability.
| ]
| [Replace inline C functions with C-- macros in .cmm code
| Simon Marlow <simonmar at microsoft.com>**20060629134726
| So that we can build the RTS with the NCG.
| ]
| [No longer force -fvia-C for the RTS, it can now be compiled with the
NCG
| Simon Marlow <simonmar at microsoft.com>**20060629135836]
| [x86-64: fix a problem exposed by negative offsets in vector tables
| Simon Marlow <simonmar at microsoft.com>**20060629140608
| static relative offsets (eg .long l1-l2) are restricted to 32 bits on
| x86-64 due to lack of support in the linker. The codegen, NCG and
| runtime work around this, using 32-bit offsets instead of 64.
| However, we were missing a workaround for vector tables, and it
| happened to work by accident because the offsets were always positive
| and resolved by the assembler. The bug was exposed by using the NCG
| to compile the RTS, where the offsets became negative, again by
| accident.
| ]
| diffing dir...
| darcs.exe: bug in darcs!
| in function reconcile_unwindings
| Original patch:
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 230
| -isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| +isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 221
| -isUnliftedTypeKind UnliftedTypeKind = True
| -isUnliftedTypeKind other = False
| +isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + | uniq == unliftedTypeKindTyConKey = True
| + | other = False
| +isUnliftedTypeKind other = False
| +
| +isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == funKindTyConKey
| +isFunKind other = False
| +
| +isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| +
| +isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == openTypeKindTyConKey
| +isRealOpenTypeKind other = False
| +
| +isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == argTypeKindTyConKey
| +isRealArgTypeKind other = False
| hunk ./compiler/types/Kind.lhs 221
| +isUnliftedBoxedTypeKind UnliftedTypeKind = True
| +isUnliftedBoxedTypeKind other = False
| +
| )
| )
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 171
| -liftedTypeKind = LiftedTypeKind
| -unliftedTypeKind = UnliftedTypeKind
| -openTypeKind = OpenTypeKind
| -argTypeKind = ArgTypeKind
| -ubxTupleKind = UbxTupleKind
| +kindTyConType :: TyCon -> Type
| +kindTyConType kind = TyConApp kind []
| +
| +liftedTypeKind = kindTyConType liftedTypeKindTyCon
| +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| +openTypeKind = kindTyConType openTypeKindTyCon
| +argTypeKind = kindTyConType argTypeKindTyCon
| +ubxTupleKind = kindTyConType ubxTupleKindTyCon
| hunk ./compiler/types/Kind.lhs 172
| +unboxedTypeKind = UnboxedTypeKind
| )
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 63
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| + | OpenTypeKind -- ?
| + | UnboxedTypeKind -- #
| + | UnliftedTypeKind -- !
| + | UbxTupleKind -- (##)
| + | ArgTypeKind -- ??
| + | FunKind Kind Kind -- k1 -> k2
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 48
| - # [UnliftedTypeKind] means unboxed type
| + # [UnboxedTypeKind] means unboxed type
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| )
| )
| )
| )
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 221
| -isUnliftedTypeKind UnliftedTypeKind = True
| -isUnliftedTypeKind other = False
| +isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + | uniq == unliftedTypeKindTyConKey = True
| + | other = False
| +isUnliftedTypeKind other = False
| +
| +isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == funKindTyConKey
| +isFunKind other = False
| +
| +isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| +
| +isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == openTypeKindTyConKey
| +isRealOpenTypeKind other = False
| +
| +isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == argTypeKindTyConKey
| +isRealArgTypeKind other = False
| hunk ./compiler/types/Kind.lhs 221
| +isUnliftedBoxedTypeKind UnliftedTypeKind = True
| +isUnliftedBoxedTypeKind other = False
| +
| )
| hunk ./compiler/types/Kind.lhs 230
| -isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| +isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| )
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 221
| +isUnliftedBoxedTypeKind UnliftedTypeKind = True
| +isUnliftedBoxedTypeKind other = False
| +
| hunk ./compiler/types/Kind.lhs 221
| -isUnliftedTypeKind UnliftedTypeKind = True
| -isUnliftedTypeKind other = False
| +isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + | uniq == unliftedTypeKindTyConKey = True
| + | other = False
| +isUnliftedTypeKind other = False
| +
| +isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == funKindTyConKey
| +isFunKind other = False
| +
| +isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| +
| +isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == openTypeKindTyConKey
| +isRealOpenTypeKind other = False
| +
| +isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == argTypeKindTyConKey
| +isRealArgTypeKind other = False
| )
| hunk ./compiler/types/Kind.lhs 225
| +isUnliftedTypeKind UnboxedTypeKind = True
| )
| )
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 171
| -liftedTypeKind = LiftedTypeKind
| -unliftedTypeKind = UnliftedTypeKind
| -openTypeKind = OpenTypeKind
| -argTypeKind = ArgTypeKind
| -ubxTupleKind = UbxTupleKind
| +kindTyConType :: TyCon -> Type
| +kindTyConType kind = TyConApp kind []
| +
| +liftedTypeKind = kindTyConType liftedTypeKindTyCon
| +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| +openTypeKind = kindTyConType openTypeKindTyCon
| +argTypeKind = kindTyConType argTypeKindTyCon
| +ubxTupleKind = kindTyConType ubxTupleKindTyCon
| hunk ./compiler/types/Kind.lhs 172
| +unboxedTypeKind = UnboxedTypeKind
| )
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 63
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| + | OpenTypeKind -- ?
| + | UnboxedTypeKind -- #
| + | UnliftedTypeKind -- !
| + | UbxTupleKind -- (##)
| + | ArgTypeKind -- ??
| + | FunKind Kind Kind -- k1 -> k2
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 48
| - # [UnliftedTypeKind] means unboxed type
| + # [UnboxedTypeKind] means unboxed type
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| )
| )
| )
| )
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 230
| -isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| +isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 221
| -isUnliftedTypeKind UnliftedTypeKind = True
| -isUnliftedTypeKind other = False
| +isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + | uniq == unliftedTypeKindTyConKey = True
| + | other = False
| +isUnliftedTypeKind other = False
| +
| +isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == funKindTyConKey
| +isFunKind other = False
| +
| +isUbxTupleKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| + = uniq == ubxTupleKindTyConKey
| +isUbxTupleKind other = False
| +
| +isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == openTypeKindTyConKey
| +isRealOpenTypeKind other = False
| +
| +isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| + = uniq == argTypeKindTyConKey
| +isRealArgTypeKind other = False
| hunk ./compiler/types/Kind.lhs 221
| +isUnliftedBoxedTypeKind UnliftedTypeKind = True
| +isUnliftedBoxedTypeKind other = False
| +
| )
| )
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 63
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| + | OpenTypeKind -- ?
| + | UnboxedTypeKind -- #
| + | UnliftedTypeKind -- !
| + | UbxTupleKind -- (##)
| + | ArgTypeKind -- ??
| + | FunKind Kind Kind -- k1 -> k2
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 48
| - # [UnliftedTypeKind] means unboxed type
| + # [UnboxedTypeKind] means unboxed type
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| )
| )
| )
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 171
| -liftedTypeKind = LiftedTypeKind
| -unliftedTypeKind = UnliftedTypeKind
| -openTypeKind = OpenTypeKind
| -argTypeKind = ArgTypeKind
| -ubxTupleKind = UbxTupleKind
| +kindTyConType :: TyCon -> Type
| +kindTyConType kind = TyConApp kind []
| +
| +liftedTypeKind = kindTyConType liftedTypeKindTyCon
| +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| +openTypeKind = kindTyConType openTypeKindTyCon
| +argTypeKind = kindTyConType argTypeKindTyCon
| +ubxTupleKind = kindTyConType ubxTupleKindTyCon
| hunk ./compiler/types/Kind.lhs 172
| +unboxedTypeKind = UnboxedTypeKind
| )
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 48
| - # [UnliftedTypeKind] means unboxed type
| + # [UnboxedTypeKind] means unboxed type
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| )
| )
| hunk ./compiler/types/Kind.lhs 63
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| + | OpenTypeKind -- ?
| + | UnboxedTypeKind -- #
| + | UnliftedTypeKind -- !
| + | UbxTupleKind -- (##)
| + | ArgTypeKind -- ??
| + | FunKind Kind Kind -- k1 -> k2
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| )
| hunk ./compiler/types/Kind.lhs 48
| - # [UnliftedTypeKind] means unboxed type
| + # [UnboxedTypeKind] means unboxed type
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| )
| hunk ./compiler/types/Kind.lhs 44
| - / \
| - * #
| + / | \
| + * ! #
| )
| merger 0.0 (
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| )
| hunk ./compiler/types/Kind.lhs 11
| - isLiftedTypeKind, isUnliftedTypeKind,
| + isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
| )
| merger 0.0 (
| merger 0.0 (
| hunk ./compiler/types/Kind.lhs 1
| -%
| -% (c) The GRASP/AQUA Project, Glasgow University, 1998
| -%
| -
| -\begin{code}
| -module Kind (
| - Kind, SuperKind(..), SimpleKind,
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| - argTypeKind, ubxTupleKind,
| -
| - isLiftedTypeKind, isUnliftedTypeKind,
| - isArgTypeKind, isOpenTypeKind,
| - mkArrowKind, mkArrowKinds,
| -
| - isSubKind, defaultKind,
| - kindFunResult, splitKindFunTys,
| -
| - KindVar, mkKindVar, kindVarRef, kindVarUniq,
| - kindVarOcc, setKindVarOcc,
| -
| - pprKind, pprParendKind
| - ) where
| -
| -#include "HsVersions.h"
| -
| -import {-# SOURCE #-} TypeRep ( Type )
| -import {-# SOURCE #-} TyCon ( TyCon )
| -import {-# SOURCE #-} TcType ( MetaDetails, TcTyVarDetails )
| -import {-# SOURCE #-} TysWiredIn
| -import Unique ( Unique )
| -import OccName ( OccName, mkOccName, tvName )
| -import Outputable
| -import DATA_IOREF
| -\end{code}
| -
| -Kinds
| -~~~~~
| -There's a little subtyping at the kind level:
| -
| - ?
| - / \
| - / \
| - ?? (#)
| - / \
| - * #
| -
| -where * [LiftedTypeKind] means boxed type
| - # [UnliftedTypeKind] means unboxed type
| - (#) [UbxTupleKind] means unboxed tuple
| - ?? [ArgTypeKind] is the lub of *,#
| - ? [OpenTypeKind] means any type at all
| -
| -In particular:
| -
| - error :: forall a:?. String -> a
| - (->) :: ?? -> ? -> *
| - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple)
| -
| -\begin{code}
| -{- Kinds are now Primitive Type Constructors (PrimTyCon)
| -data Kind
| - = LiftedTypeKind -- *
| - | OpenTypeKind -- ?
| - | UnliftedTypeKind -- #
| - | UbxTupleKind -- (##)
| - | ArgTypeKind -- ??
| - | FunKind Kind Kind -- k1 -> k2
| - | KindVar KindVar
| - deriving( Eq )
| -
| -data KindVar = KVar Unique OccName (IORef (Maybe SimpleKind))
| - -- INVARIANT: a KindVar can only be instantiated by a SimpleKind
| -
| -type SimpleKind = Kind
| - -- A SimpleKind has no ? or # kinds in it:
| - -- sk ::= * | sk1 -> sk2 | kvar
| --}
| -
| -
| -type KindVar = TyVar -- invariant: KindVar will always be a
| - -- TcTyVar with details MetaTv TauTv
| -
| -{-
| -instance Eq KindVar where
| - (KVar u1 _ _) == (KVar u2 _ _) = u1 == u2
| --}
| -
| -mkKindName :: Unique -> Name
| -mkKindName unique
| - = Name { n_sort = System
| - , n_occ = kind_var_occ
| - , n_uniq = unique
| - , n_loc = UnhelpfulLoc (mkFastString "Kind Variable,
internal")
| - }
| -
| -mkKindVar :: Unique -> IORef MetaDetails -> KindVar
| -mkKindVar u r
| - = TcTyVar { varName = mkKindName u
| - , realUnique = u
| - , tyVarKind = boxSuperKindTy -- not sure this is
right,
| - -- do we need kind
vars for
| - -- coercions?
| - , tcTyVarDetails = MetaTv TauTv r
| - }
| -
| -kindVarRef :: KindVar -> IORef MetaDetails
| -kindVarRef (TcTyVar{tcTyVarDetails = MetaTv TauTv ref}) = ref
| -kindVarRef other = pprPanic "kindVarRef" (ppr
other)
| -
| -kindVarUniq :: KindVar -> Unique
| -kindVarUniq (TcTyVar{realUnique = uniq}) = uniq
| -kindVarUniq other = pprPanic "kindVarUniq"
(ppr other)
| -
| -kindVarOcc :: KindVar -> OccName
| -kindVarOcc (TcTyVar{varName = Name {n_occ = occ}})
| - = occ
| -kindVarOcc other
| - = pprPanic "kindVarOcc" (ppr other)
| -
| -setKindVarOcc :: KindVar -> OccName -> KindVar
| -setKindVarOcc (rec@((TcTyVar {varName = name}))) occ
| - = (rec{ varName = name{ n_occ = occ } })
| -setKindVarOcc other occ = pprPanic "setKindVarOcc" (ppr other)
| -
| -kind_var_occ :: OccName -- Just one for all KindVars
| - -- They may be jiggled by tidying
| -kind_var_occ = mkOccName tvName "k"
| -\end{code}
| -
| -Super Kinds
| -~~~~~~~~~~~
| -There are two super kinds:
| -
| - [] is the super kind of type kinds, ? and all kinds it subsumes
have [] kind
| - <> is the super kind of type coercions
| -
| -\begin{code}
| -data SuperKind
| - = BoxSuperKind
| - | DiamondSuperKind
| -
| -\end{code}
| -
| -Kind inference
| -~~~~~~~~~~~~~~
| -During kind inference, a kind variable unifies only with
| -a "simple kind", sk
| - sk ::= * | sk1 -> sk2
| -For example
| - data T a = MkT a (T Int#)
| -fails. We give T the kind (k -> *), and the kind variable k won't
unify
| -with # (the kind of Int#).
| -
| -Type inference
| -~~~~~~~~~~~~~~
| -When creating a fresh internal type variable, we give it a kind to
express
| -constraints on it. E.g. in (\x->e) we make up a fresh type variable
for x,
| -with kind ??.
| -
| -During unification we only bind an internal type variable to a type
| -whose kind is lower in the sub-kind hierarchy than the kind of the
tyvar.
| -
| -When unifying two internal type variables, we collect their kind
constraints by
| -finding the GLB of the two. Since the partial order is a tree, they
only
| -have a glb if one is a sub-kind of the other. In that case, we bind
the
| -less-informative one to the more informative one. Neat, eh?
| -
| -
| -\begin{code}
| -kindTyConType :: TyCon -> Type
| -kindTyConType kind = TyConApp kind []
| -
| -liftedTypeKind = kindTyConType liftedTypeKindTyCon
| -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
| -openTypeKind = kindTyConType openTypeKindTyCon
| -argTypeKind = kindTyConType argTypeKindTyCon
| -ubxTupleKind = kindTyConType ubxTupleKindTyCon
| -
| -mkArrowKind :: Kind -> Kind -> Kind
| -mkArrowKind k1 k2 = TyConApp funKindTyCon [k1,k2]
| -
| -mkArrowKinds :: [Kind] -> Kind -> Kind
| -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind
arg_kinds
| -\end{code}
| -
|
-%**********************************************************************
**
| -%*
*
| - Functions over Kinds
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -kindFunResult :: Kind -> Kind
| -kindFunResult k = funResultTy k
| -
| -splitKindFunTys :: Kind -> ([Kind],Kind)
| -splitKindFunTys (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] ->
| - case splitKindFunTys k2 of
| - (as, r) -> (k1:as, r)
| - other -> pprPanic "splitKindFunTys" "funKind does not have
two arguments"
| - | otherwise = ([], k)
| -splitKindFunTys other = pprPanic "splitKindFunTys" (ppr other)
| -
| -shallowSplitFunKind :: Kind -> (Kind, Kind)
| -shallowSplitFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == funKindTyConKey =
| - case args of
| - [k1, k2] -> (k1, k2)
| - other -> pprPanic "shallowSplitFunKind" "funKind does not
have two arguments"
| - | otherwise = pprPanic "shallowSplitFunKind" (ppr k)
| -shallowSplitFunKind other = pprPanic "shallowSplitFunKind" (ppr
other)
| -
| -isLiftedTypeKind, isUnliftedTypeKind, isFunKind, isUbxTupleKind,
isRealOpenTypeKind,
| isRealArgTypeKind :: Kind -> Bool
| -
| -isLiftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == liftedTypeKindTyConKey = True
| - | other = False
| -isLiftedTypeKind other = False
| -
| -isUnliftedTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | other = False
| -isUnliftedTypeKind other = False
| -
| -isFunKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - = uniq == funKindTyConKey
| -isFunKind other = False
| -
| -isUbxTupleKind (TyConApp tc _) = tyConUnique tc ==
ubxTupleKindTyConKey
| -isUbxTupleKind other = False
| -
| -isRealOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == openTypeKindTyConKey
| -isRealOpenTypeKind other = False
| -
| -isRealArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq})
args))
| - = uniq == argTypeKindTyConKey
| -isRealArgTypeKind other = False
| -
| -isArgTypeKind :: Kind -> Bool
| --- True of any sub-kind of ArgTypeKind
| -isArgTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == unliftedTypeKindTyConKey = True
| - | uniq == liftedTypeKindTyConKey = True
| - | uniq == argTypeKindTyConKey = True
| - | otherwise = False
| -isArgTypeKind other = False
| -
| -isOpenTypeKind :: Kind -> Bool
| --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
| -isOpenTypeKind (k@(TyConApp (PrimTyCon {tyConUnique = uniq}) args))
| - | uniq == funKindTyConKey = False
| - | otherwise = ASSERT( isKind other ) True
| -isOpenTypeKind other = ASSERT( isKind other ) False
| - -- This is a conservative answer
| - -- It matters in the call to isSubKind in
| - -- checkExpectedKind.
| -
| -isSubKind :: Kind -> Kind -> Bool
| --- (k1 `isSubKind` k2) checks that k1 <: k2
| -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon`
kc1
| -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind`
a1) && (r1 `isSubKind` r2)
| -isSubKind k1 k2 = False
| -
| -isSubKindCon :: KindCon -> KindCon -> Bool
| --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2
| -isSubKindCon kc1 kc2
| - | uniq1 == liftedTypeKindTyConKey && uniq2 ==
liftedTypeKindTyConKey = True
| - | uniq1 == unliftedTypeKindTyConKey && uniq2 ==
unliftedTypeKindTyConKey = True
| - | uniq1 == ubxTupleKindTyConKey && uniq2 == ubxTupleKindTyConKey =
True
| - | uniq2 == openTypeKindTyConKey && isOpenTypeKind k1 = True
| - | uniq2 == argTypeKindTyConKey && isArgTypeKind k1 = True
| -
| -defaultKind :: Kind -> Kind
| --- Used when generalising: default kind '?' and '??' to '*'
| ---
| --- When we generalise, we make generic type variables whose kind is
| --- simple (* or *->* etc). So generic type variables (other than
| --- built-in constants like 'error') always have simple kinds. This
is important;
| --- consider
| --- f x = True
| --- We want f to get type
| --- f :: forall (a::*). a -> Bool
| --- Not
| --- f :: forall (a::??). a -> Bool
| --- because that would allow a call like (f 3#) as well as (f True),
| ---and the calling conventions differ. This defaulting is done in
TcMType.zonkTcTyVarBndr.
| -defaultKind k
| - | isOpenTypeKind k = liftedTypeKind
| - | isArgTypeKind k = liftedTypeKind
| - | otherwise = k
| -\end{code}
| -
| -
|
-%**********************************************************************
**
| -%*
*
| - Pretty printing
| -%*
*
|
-%**********************************************************************
**
| -
| -\begin{code}
| -
| -pprParendKind :: Kind -> SDoc
| -pprParendKind k
| - | isFunKind k = parens (pprKind k)
| - | otherwise = pprKind k
| -
| -pprKind k
| - | isLiftedTypeKind k = ptext SLIT("*")
| - | isUnliftedTypeKind k = ptext SLIT("#")
| - | isUbxTupleKind k = ptext SLIT("(#)")
| - | isFunKind k =
| - let (k1, k2) = shallowSplitFunKind k in
| - sep [ pprParendKind k1, arrow <+> pprKind k2]
| - | isRealOpenTypeKind k = ptext SLIT("?")
| - | isRealArgTypeKind k = ptext SLIT("??")
| -
| -
| -\end{code}
| hunk ./compiler/types/Kind.lhs 8
| - openTypeKind, liftedTypeKind, unliftedTypeKind,
| + openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
| )
| rmfile ./compiler/types/Kind.lhs
| )
| )
| )
| )
| )
| )
| )
| )
| Please report this to bugs at darcs.net
| If possible include the output of 'darcs --exact-version'.
| sh-2.04$
----------
messages: 730
nosy: droundy, simonpj, tommy
status: unread
title: Another darcs crash
____________________________________
Darcs issue tracker <bugs at darcs.net>
<http://bugs.darcs.net/issue197>
____________________________________
More information about the darcs-devel
mailing list