Commit ee6fba89 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari
Browse files

Encode strictness in GHC generics metadata

This augments `MetaSel` with a `Bang` field, which gives generic
programmers access to the following information about each field
selector:

* `SourceUnpackedness`: whether a field was marked `{-# NOUNPACK #-}`,
  `{-# UNPACK #-}`, or not
* `SourceStrictness`: whether a field was given a strictness (`!`) or
  laziness (`~`) annotation
* `DecidedStrictness`: what strictness GHC infers for a field during
  compilation, which may be influenced by optimization levels,
  `-XStrictData`, `-funbox-strict-fields`, etc.

Unlike in Phab:D1603, generics does not grant a programmer the ability
to "splice" in metadata, so there is no issue including
`DecidedStrictness` with `Bang` (whereas in Template Haskell, it had to
be split off).

One consequence of this is that `MetaNoSel` had to be removed, since it
became redundant. The `NoSelector` empty data type was also removed for
similar reasons.

Fixes #10716.

Test Plan: ./validate

Reviewers: dreixel, goldfire, kosmikus, austin, hvr, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1646

GHC Trac Issues: #10716
parent 99b956ef
......@@ -392,8 +392,11 @@ genericTyConNames = [
uFloatTyConName, uIntTyConName, uWordTyConName,
prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
rightAssociativeDataConName, notAssociativeDataConName,
metaDataDataConName, metaConsDataConName,
metaSelDataConName, metaNoSelDataConName
sourceUnpackDataConName, sourceNoUnpackDataConName,
noSourceUnpackednessDataConName, sourceLazyDataConName,
sourceStrictDataConName, noSourceStrictnessDataConName,
decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,
metaDataDataConName, metaConsDataConName, metaSelDataConName
]
{-
......@@ -873,8 +876,11 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
uFloatTyConName, uIntTyConName, uWordTyConName,
prefixIDataConName, infixIDataConName, leftAssociativeDataConName,
rightAssociativeDataConName, notAssociativeDataConName,
metaDataDataConName, metaConsDataConName,
metaSelDataConName, metaNoSelDataConName :: Name
sourceUnpackDataConName, sourceNoUnpackDataConName,
noSourceUnpackednessDataConName, sourceLazyDataConName,
sourceStrictDataConName, noSourceStrictnessDataConName,
decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,
metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
......@@ -915,10 +921,19 @@ leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") le
rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey
notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey
sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey
sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey
noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey
sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey
sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey
noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey
decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey
decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey
decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey
metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey
metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey
metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey
metaNoSelDataConName = dcQual gHC_GENERICS (fsLit "MetaNoSel") metaNoSelDataConKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
......@@ -1823,17 +1838,28 @@ typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53
prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,
rightAssociativeDataConKey, notAssociativeDataConKey,
metaDataDataConKey, metaConsDataConKey,
metaSelDataConKey, metaNoSelDataConKey :: Unique
sourceUnpackDataConKey, sourceNoUnpackDataConKey,
noSourceUnpackednessDataConKey, sourceLazyDataConKey,
sourceStrictDataConKey, noSourceStrictnessDataConKey,
decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,
metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique
prefixIDataConKey = mkPreludeDataConUnique 54
infixIDataConKey = mkPreludeDataConUnique 55
leftAssociativeDataConKey = mkPreludeDataConUnique 56
rightAssociativeDataConKey = mkPreludeDataConUnique 57
notAssociativeDataConKey = mkPreludeDataConUnique 58
metaDataDataConKey = mkPreludeDataConUnique 59
metaConsDataConKey = mkPreludeDataConUnique 60
metaSelDataConKey = mkPreludeDataConUnique 61
metaNoSelDataConKey = mkPreludeDataConUnique 62
sourceUnpackDataConKey = mkPreludeDataConUnique 59
sourceNoUnpackDataConKey = mkPreludeDataConUnique 60
noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61
sourceLazyDataConKey = mkPreludeDataConUnique 62
sourceStrictDataConKey = mkPreludeDataConUnique 63
noSourceStrictnessDataConKey = mkPreludeDataConUnique 64
decidedLazyDataConKey = mkPreludeDataConUnique 65
decidedStrictDataConKey = mkPreludeDataConUnique 66
decidedUnpackDataConKey = mkPreludeDataConUnique 67
metaDataDataConKey = mkPreludeDataConUnique 68
metaConsDataConKey = mkPreludeDataConUnique 69
metaSelDataConKey = mkPreludeDataConUnique 70
---------------- Template Haskell -------------------
-- THNames.hs: USES DataUniques 100-150
......
......@@ -54,7 +54,8 @@ module TysWiredIn (
-- * Maybe
maybeTyCon, maybeTyConName,
nothingDataCon, nothingDataConName, justDataCon, justDataConName,
nothingDataCon, nothingDataConName, promotedNothingDataCon,
justDataCon, justDataConName, promotedJustDataCon,
-- * Tuples
mkTupleTy, mkBoxedTupleTy,
......@@ -1046,6 +1047,11 @@ promotedFalseDataCon, promotedTrueDataCon :: TyCon
promotedTrueDataCon = promoteDataCon trueDataCon
promotedFalseDataCon = promoteDataCon falseDataCon
-- Promoted Maybe
promotedNothingDataCon, promotedJustDataCon :: TyCon
promotedNothingDataCon = promoteDataCon nothingDataCon
promotedJustDataCon = promoteDataCon justDataCon
-- Promoted Ordering
promotedLTDataCon
......
......@@ -43,6 +43,7 @@ import FastString
import Util
import Control.Monad (mplus)
import Data.List (zip4)
import Data.Maybe (isJust)
#include "HsVersions.h"
......@@ -499,12 +500,20 @@ tc_mkRepTy gk_ tycon =
md <- tcLookupPromDataCon metaDataDataConName
mc <- tcLookupPromDataCon metaConsDataConName
ms <- tcLookupPromDataCon metaSelDataConName
mns <- tcLookupPromDataCon metaNoSelDataConName
pPrefix <- tcLookupPromDataCon prefixIDataConName
pInfix <- tcLookupPromDataCon infixIDataConName
pLA <- tcLookupPromDataCon leftAssociativeDataConName
pRA <- tcLookupPromDataCon rightAssociativeDataConName
pNA <- tcLookupPromDataCon notAssociativeDataConName
pSUpk <- tcLookupPromDataCon sourceUnpackDataConName
pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName
pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
pSLzy <- tcLookupPromDataCon sourceLazyDataConName
pSStr <- tcLookupPromDataCon sourceStrictDataConName
pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
pDLzy <- tcLookupPromDataCon decidedLazyDataConName
pDStr <- tcLookupPromDataCon decidedStrictDataConName
pDUpk <- tcLookupPromDataCon decidedUnpackDataConName
fix_env <- getFixityEnv
......@@ -518,22 +527,26 @@ tc_mkRepTy gk_ tycon =
mkC a = mkTyConApp c1 [ metaConsTy a
, prod (dataConInstOrigArgTys a
. mkTyVarTys . tyConTyVars $ tycon)
(dataConSrcBangs a)
(dataConImplBangs a)
(dataConFieldLabels a)]
mkS mlbl a = mkTyConApp s1 [metaSelTy mlbl, a]
mkS mlbl su ss ib a = mkTyConApp s1 [metaSelTy mlbl su ss ib, a]
-- Sums and products are done in the same way for both Rep and Rep1
sumP [] = mkTyConTy v1
sumP l = foldBal mkSum' . map mkC $ l
-- The Bool is True if this constructor has labelled fields
prod :: [Type] -> [FieldLabel] -> Type
prod [] _ = mkTyConTy u1
prod l fl = foldBal mkProd [ ASSERT(null fl || length fl > j)
arg t (if null fl then Nothing
prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
prod [] _ _ _ = mkTyConTy u1
prod l sb ib fl = foldBal mkProd
[ ASSERT(null fl || length fl > j)
arg t sb' ib' (if null fl
then Nothing
else Just (fl !! j))
| (t,j) <- zip l [0..] ]
| (t,sb',ib',j) <- zip4 l sb ib [0..] ]
arg :: Type -> Maybe FieldLabel -> Type
arg t fl = mkS fl $ case gk_ of
arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
-- Here we previously used Par0 if t was a type variable, but we
-- realized that we can't always guarantee that we are wrapping-up
-- all type variables in Par0. So we decided to stop using Par0
......@@ -580,10 +593,29 @@ tc_mkRepTy gk_ tycon =
selName = mkStrLitTy . flLabel
mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind]
mbSel (Just s) = mkTyConApp promotedJustDataCon
[typeSymbolKind, selName s]
metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT]
metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
metaSelTy Nothing = mkTyConTy mns
metaSelTy (Just s) = mkTyConApp ms [selName s]
metaSelTy mlbl su ss ib =
mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
where
pSUpkness = mkTyConTy $ case su of
SrcUnpack -> pSUpk
SrcNoUnpack -> pSNUpk
NoSrcUnpack -> pNSUpkness
pSStrness = mkTyConTy $ case ss of
SrcLazy -> pSLzy
SrcStrict -> pSStr
NoSrcStrict -> pNSStrness
pDStrness = mkTyConTy $ case ib of
HsLazy -> pDLzy
HsStrict -> pDStr
HsUnpack{} -> pDUpk
return (mkD tycon)
......
......@@ -105,6 +105,9 @@ Language
arguments with certain unlifted types. See :ref:`generic-programming` for
more details.
- GHC generics can now provide strictness information for fields in a data
constructor via the ``Selector`` type class.
- The ``-XDeriveAnyClass`` extension now fills in associated type family
default instances when deriving a class that contains them.
......
......@@ -12530,11 +12530,23 @@ representation:
instance Generic (UserTree a) where
-- Representation type
type Rep (UserTree a) =
M1 D ('MetaData "UserTree" "Main" "package-name" "foo" 'False) (
M1 D ('MetaData "UserTree" "Main" "package-name" 'False) (
M1 C ('MetaCons "Node" 'PrefixI 'False) (
M1 S 'MetaNoSel (K1 R a)
:*: M1 S 'MetaNoSel (K1 R (UserTree a))
:*: M1 S 'MetaNoSel (K1 R (UserTree a)))
M1 S ('MetaSel 'Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(K1 R a)
:*: M1 S ('MetaSel 'Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(K1 R (UserTree a))
:*: M1 S ('MetaSel 'Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
(K1 R (UserTree a)))
:+: M1 C ('MetaCons "Leaf" 'PrefixI 'False) U1)
-- Conversion functions
......@@ -12612,11 +12624,15 @@ As an example, this data declaration: ::
results in the following ``Generic`` instance: ::
instance Generic IntHash where
type Rep IntHash =
D1 D1IntHash
(C1 C1_0IntHash
(S1 NoSelector UInt))
instance 'Generic' IntHash where
type 'Rep' IntHash =
'D1' ('MetaData "IntHash" "Main" "package-name" 'False)
('C1' ('MetaCons "IntHash" 'PrefixI 'False)
('S1' ('MetaSel 'Nothing
'NoSourceUnpackedness
'NoSourceStrictness
'DecidedLazy)
'UInt'))
A user could provide, for example, a ``GSerialize UInt`` instance so that a
``Serialize IntHash`` instance could be easily defined in terms of
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
......@@ -75,12 +74,24 @@ module GHC.Generics (
-- type 'Rep' (Tree a) =
-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)
-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel ('Rec0' a))
-- ('S1' '(MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec0' a))
-- ':+:'
-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel ('Rec0' (Tree a))
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec0' (Tree a))
-- ':*:'
-- 'S1' 'MetaNoSel ('Rec0' (Tree a))))
-- 'S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec0' (Tree a))))
-- ...
-- @
--
......@@ -114,8 +125,27 @@ module GHC.Generics (
--
-- Now let us explain the additional tags being used in the complete representation:
--
-- * The @'S1' 'MetaNoSel@ indicates that there is no record field selector
-- associated with this field of the constructor.
-- * The @'S1' ('MetaSel 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness
-- 'DecidedLazy)@ tag indicates several things. The @'Nothing@ indicates
-- that there is no record field selector associated with this field of
-- the constructor (if there were, it would have been marked @'Just
-- \"recordName\"@ instead). The other types contain meta-information on
-- the field's strictness:
--
-- * There is no @{\-\# UNPACK \#-\}@ or @{\-\# NOUNPACK \#-\}@ annotation
-- in the source, so it is tagged with @'NoSourceUnpackedness@.
--
-- * There is no strictness (@!@) or laziness (@~@) annotation in the
-- source, so it is tagged with @'NoSourceStrictness@.
--
-- * The compiler infers that the field is lazy, so it is tagged with
-- @'DecidedLazy@. Bear in mind that what the compiler decides may be
-- quite different from what is written in the source. See
-- 'DecidedStrictness' for a more detailed explanation.
--
-- The @'MetaSel@ type is also an instance of the type class 'Selector',
-- which can be used to obtain information about the field at the value
-- level.
--
-- * The @'C1' ('MetaCons \"Leaf\" 'PrefixI 'False)@ and
-- @'C1' ('MetaCons \"Node\" 'PrefixI 'False)@ invocations indicate that the enclosed part is
......@@ -462,12 +492,24 @@ module GHC.Generics (
-- type 'Rep1' Tree =
-- 'D1' ('MetaData \"Tree\" \"Main\" \"package-name\" 'False)
-- ('C1' ('MetaCons \"Leaf\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel 'Par1')
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- 'Par1')
-- ':+:'
-- 'C1' ('MetaCons \"Node\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel ('Rec1' Tree)
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec1' Tree)
-- ':*:'
-- 'S1' 'MetaNoSel ('Rec1' Tree)))
-- 'S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec1' Tree)))
-- ...
-- @
--
......@@ -513,9 +555,17 @@ module GHC.Generics (
-- type 'Rep1' WithInt =
-- 'D1' ('MetaData \"WithInt\" \"Main\" \"package-name\" 'False)
-- ('C1' ('MetaCons \"WithInt\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel ('Rec0' Int)
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ('Rec0' Int)
-- ':*:'
-- 'S1' 'MetaNoSel 'Par1'))
-- 'S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- 'Par1'))
-- @
--
-- If the parameter @a@ appears underneath a composition of other type constructors,
......@@ -532,9 +582,17 @@ module GHC.Generics (
-- type 'Rep1' Rose =
-- 'D1' ('MetaData \"Rose\" \"Main\" \"package-name\" 'False)
-- ('C1' ('MetaCons \"Fork\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel 'Par1'
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- 'Par1'
-- ':*:'
-- 'S1' 'MetaNoSel ([] ':.:' 'Rec1' Rose)
-- 'S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- ([] ':.:' 'Rec1' Rose)))
-- @
--
-- where
......@@ -596,7 +654,11 @@ module GHC.Generics (
-- type 'Rep' IntHash =
-- 'D1' ('MetaData \"IntHash\" \"Main\" \"package-name\" 'False)
-- ('C1' ('MetaCons \"IntHash\" 'PrefixI 'False)
-- ('S1' 'MetaNoSel 'UInt'))
-- ('S1' ('MetaSel 'Nothing
-- 'NoSourceUnpackedness
-- 'NoSourceStrictness
-- 'DecidedLazy)
-- 'UInt'))
-- @
--
-- Currently, only the six unlifted types listed above are generated, but this
......@@ -627,8 +689,9 @@ module GHC.Generics (
, D1, C1, S1, D, C, S
-- * Meta-information
, Datatype(..), Constructor(..), Selector(..), NoSelector
, Datatype(..), Constructor(..), Selector(..)
, Fixity(..), FixityI(..), Associativity(..), prec
, SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..)
, Meta(..)
-- * Generic type classes
......@@ -641,10 +704,11 @@ import GHC.Integer ( Integer, integerToInt )
import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
import GHC.Ptr ( Ptr )
import GHC.Types
import Data.Maybe ( Maybe(..) )
import Data.Maybe ( Maybe(..), fromMaybe )
import Data.Either ( Either(..) )
-- Needed for instances
import GHC.Base ( String )
import GHC.Classes ( Eq, Ord )
import GHC.Read ( Read )
import GHC.Show ( Show )
......@@ -814,22 +878,78 @@ data Associativity = LeftAssociative
| NotAssociative
deriving (Eq, Show, Ord, Read, Generic)
-- | The unpackedness of a field as the user wrote it in the source code. For
-- example, in the following data type:
--
-- @
-- data E = ExampleConstructor Int
-- {\-\# NOUNPACK \#-\} Int
-- {\-\# UNPACK \#-\} Int
-- @
--
-- The fields of @ExampleConstructor@ have 'NoSourceUnpackedness',
-- 'SourceNoUnpack', and 'SourceUnpack', respectively.
data SourceUnpackedness = NoSourceUnpackedness
| SourceNoUnpack
| SourceUnpack
deriving (Eq, Show, Ord, Read, Generic)
-- | The strictness of a field as the user wrote it in the source code. For
-- example, in the following data type:
--
-- @
-- data E = ExampleConstructor Int ~Int !Int
-- @
--
-- The fields of @ExampleConstructor@ have 'NoSourceStrictness',
-- 'SourceLazy', and 'SourceStrict', respectively.
data SourceStrictness = NoSourceStrictness
| SourceLazy
| SourceStrict
deriving (Eq, Show, Ord, Read, Generic)
-- | The strictness that GHC infers for a field during compilation. Whereas
-- there are nine different combinations of 'SourceUnpackedness' and
-- 'SourceStrictness', the strictness that GHC decides will ultimately be one
-- of lazy, strict, or unpacked. What GHC decides is affected both by what the
-- user writes in the source code and by GHC flags. As an example, consider
-- this data type:
--
-- @
-- data E = ExampleConstructor {\-\# UNPACK \#-\} !Int !Int Int
-- @
--
-- * If compiled without optimization or other language extensions, then the
-- fields of @ExampleConstructor@ will have 'DecidedStrict', 'DecidedStrict',
-- and 'DecidedLazy', respectively.
--
-- * If compiled with @-XStrictData@ enabled, then the fields will have
-- 'DecidedStrict', 'DecidedStrict', and 'DecidedStrict', respectively.
--
-- * If compiled with @-O2@ enabled, then the fields will have 'DecidedUnpack',
-- 'DecidedStrict', and 'DecidedLazy', respectively.
data DecidedStrictness = DecidedLazy
| DecidedStrict
| DecidedUnpack
deriving (Eq, Show, Ord, Read, Generic)
-- | Class for datatypes that represent records
class Selector s where
-- | The name of the selector
selName :: t s (f :: * -> *) a -> [Char]
-- | Used for constructor fields without a name
-- Deprecated in 7.9
{-# DEPRECATED NoSelector "'NoSelector' is no longer used" #-}
data NoSelector
instance Selector NoSelector where selName _ = ""
instance (KnownSymbol s) => Selector ('MetaSel s) where
selName _ = symbolVal (Proxy :: Proxy s)
instance Selector 'MetaNoSel where
selName _ = ""
-- | The selector's unpackedness annotation (if any)
selSourceUnpackedness :: t s (f :: * -> *) a -> SourceUnpackedness
-- | The selector's strictness annotation (if any)
selSourceStrictness :: t s (f :: * -> *) a -> SourceStrictness
-- | The strictness that the compiler inferred for the selector
selDecidedStrictness :: t s (f :: * -> *) a -> DecidedStrictness
instance (SingI mn, SingI su, SingI ss, SingI ds)
=> Selector ('MetaSel mn su ss ds) where
selName _ = fromMaybe "" (fromSing (sing :: Sing mn))
selSourceUnpackedness _ = fromSing (sing :: Sing su)
selSourceStrictness _ = fromSing (sing :: Sing ss)
selDecidedStrictness _ = fromSing (sing :: Sing ds)
-- | Representable types of kind *.
-- This class is derivable in GHC with the DeriveGeneric flag on.
......@@ -857,7 +977,7 @@ class Generic1 f where
--------------------------------------------------------------------------------
-- | Datatype to represent metadata associated with a datatype (@MetaData@),
-- constructor (@MetaCons@), or field (@MetaSel@ and @MetaNoSel@).
-- constructor (@MetaCons@), or field selector (@MetaSel@).
--
-- * In @MetaData n m p nt@, @n@ is the datatype's name, @m@ is the module in
-- which the datatype is defined, @p@ is the package in which the datatype
......@@ -866,14 +986,14 @@ class Generic1 f where
-- * In @MetaCons n f s@, @n@ is the constructor's name, @f@ is its fixity,
-- and @s@ is @'True@ if the constructor contains record selectors.
--
-- * Fields with record selectors are tagged with @MetaSel s@, where @s@ is
-- the record selector name.
--
-- * Fields without record selectors are tagged with @MetaNoSel@.
-- * In @MetaSel mn su ss ds@, if the field is uses record syntax, then @mn@ is
-- 'Just' the record name. Otherwise, @mn@ is 'Nothing. @su@ and @ss@ are the
-- field's unpackedness and strictness annotations, and @ds@ is the
-- strictness that GHC infers for the field.
data Meta = MetaData Symbol Symbol Symbol Bool
| MetaCons Symbol FixityI Bool
| MetaSel Symbol
| MetaNoSel
| MetaSel (Maybe Symbol)
SourceUnpackedness SourceStrictness DecidedStrictness
--------------------------------------------------------------------------------
-- Derived instances
......@@ -930,6 +1050,16 @@ class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where
-- | Convert a singleton to its unrefined version.
fromSing :: Sing (a :: k) -> DemoteRep kparam
-- Singleton symbols
data instance Sing (_s :: Symbol) where
SSym :: KnownSymbol s => Sing s
instance KnownSymbol a => SingI a where sing = SSym
instance SingKind ('KProxy :: KProxy Symbol) where
type DemoteRep ('KProxy :: KProxy Symbol) = String
fromSing (SSym :: Sing s) = symbolVal (Proxy :: Proxy s)
-- Singleton booleans
data instance Sing (_a :: Bool) where
STrue :: Sing 'True
......@@ -943,6 +1073,21 @@ instance SingKind ('KProxy :: KProxy Bool) where
fromSing STrue = True
fromSing SFalse = False
-- Singleton Maybe
data instance Sing (_b :: Maybe _a) where
SNothing :: Sing 'Nothing
SJust :: Sing a -> Sing ('Just a)
instance SingI 'Nothing where sing = SNothing
instance SingI a => SingI ('Just a) where sing = SJust sing
instance SingKind ('KProxy :: KProxy a) =>
SingKind ('KProxy :: KProxy (Maybe a)) where
type DemoteRep ('KProxy :: KProxy (Maybe a)) =
Maybe (DemoteRep ('KProxy :: KProxy a))
fromSing SNothing = Nothing
fromSing (SJust a) = Just (fromSing a)
-- Singleton Fixity
data instance Sing (_a :: FixityI) where
SPrefix :: Sing 'PrefixI
......@@ -972,3 +1117,51 @@ instance SingKind ('KProxy :: KProxy Associativity) where
fromSing SLeftAssociative = LeftAssociative
fromSing SRightAssociative = RightAssociative