Commit 7b962bab authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari

Implement OverloadedLabels

See
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels
for the big picture.

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj, bgamari

Subscribers: kosmikus, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1331
parent acce37f3
......@@ -465,6 +465,7 @@ addTickHsExpr e@(HsVar id) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
......
......@@ -199,6 +199,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
......
......@@ -1072,6 +1072,7 @@ repE (HsVar x) =
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar x)
......
......@@ -986,6 +986,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- the instance for IPName derives using the id, so this works if the
-- above does
exp (HsIPVar i) (HsIPVar i') = i == i'
exp (HsOverLabel l) (HsOverLabel l') = l == l'
exp (HsOverLit l) (HsOverLit l') =
-- Overloaded lits are equal if they have the same type
-- and the data is the same.
......
......@@ -138,6 +138,8 @@ data HsExpr id
| HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
| HsOverLabel FastString -- ^ Overloaded label (See Note [Overloaded labels]
-- in GHC.OverloadedLabels)
| HsIPVar HsIPName -- ^ Implicit parameter
| HsOverLit (HsOverLit id) -- ^ Overloaded literals
......@@ -626,6 +628,7 @@ ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
ppr_expr (HsVar v) = pprPrefixOcc v
ppr_expr (HsUnboundVar v) = pprPrefixOcc v
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsOverLabel l) = char '#' <> ppr l
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsPar e) = parens (ppr_lexpr e)
......@@ -844,6 +847,7 @@ hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsUnboundVar {}) = False
hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (HsOverLabel {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False
......@@ -865,6 +869,7 @@ isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
......
......@@ -648,6 +648,7 @@ data ExtensionFlag
| Opt_BinaryLiterals
| Opt_NegativeLiterals
| Opt_DuplicateRecordFields
| Opt_OverloadedLabels
| Opt_EmptyCase
| Opt_PatternSynonyms
| Opt_PartialTypeSignatures
......@@ -3184,6 +3185,7 @@ xFlags = [
flagSpec "NumDecimals" Opt_NumDecimals,
flagSpec' "OverlappingInstances" Opt_OverlappingInstances
setOverlappingInsts,
flagSpec "OverloadedLabels" Opt_OverloadedLabels,
flagSpec "OverloadedLists" Opt_OverloadedLists,
flagSpec "OverloadedStrings" Opt_OverloadedStrings,
flagSpec "PackageImports" Opt_PackageImports,
......
......@@ -260,7 +260,8 @@ $tab { warnTab }
-- with {-#, then we'll assume it's a pragma we know about and go for do_bol.
<bol> {
\n ;
^\# (line)? { begin line_prag1 }
^\# line { begin line_prag1 }
^\# / { followedByDigit } { begin line_prag1 }
^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently
^\# \! .* \n ; -- #!, for scripts
() { do_bol }
......@@ -401,6 +402,11 @@ $tab { warnTab }
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
<0> {
"#" @varid / { ifExtension overloadedLabelsEnabled }
{ skip_one_varid ITlabelvarid }
}
<0> {
"(#" / { ifExtension unboxedTuplesEnabled }
{ token IToubxparen }
......@@ -633,6 +639,7 @@ data Token
| ITqconsym (FastString,FastString)
| ITdupipvarid FastString -- GHC extension: implicit param: ?x
| ITlabelvarid FastString -- Overloaded label: #x
| ITchar SourceText Char -- Note [Literal source text] in BasicTypes
| ITstring SourceText FastString -- Note [Literal source text] in BasicTypes
......@@ -906,6 +913,10 @@ notFollowedBySymbol :: AlexAccPred ExtsBitmap
notFollowedBySymbol _ _ _ (AI _ buf)
= nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
followedByDigit :: AlexAccPred ExtsBitmap
followedByDigit _ _ _ (AI _ buf)
= afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9']))
-- We must reject doc comments as being ordinary comments everywhere.
-- In some cases the doc comment will be selected as the lexeme due to
-- maximal munch, but not always, because the nested comment rule is
......@@ -1984,6 +1995,7 @@ data ExtBits
| ArrowsBit
| ThBit
| IpBit
| OverloadedLabelsBit -- #x overloaded labels
| ExplicitForallBit -- the 'forall' keyword and '.' symbol
| BangPatBit -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
......@@ -2023,6 +2035,8 @@ thEnabled :: ExtsBitmap -> Bool
thEnabled = xtest ThBit
ipEnabled :: ExtsBitmap -> Bool
ipEnabled = xtest IpBit
overloadedLabelsEnabled :: ExtsBitmap -> Bool
overloadedLabelsEnabled = xtest OverloadedLabelsBit
explicitForallEnabled :: ExtsBitmap -> Bool
explicitForallEnabled = xtest ExplicitForallBit
bangPatEnabled :: ExtsBitmap -> Bool
......@@ -2113,6 +2127,7 @@ mkPState flags buf loc =
.|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. IpBit `setBitIf` xopt Opt_ImplicitParams flags
.|. OverloadedLabelsBit `setBitIf` xopt Opt_OverloadedLabels flags
.|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. HaddockBit `setBitIf` gopt Opt_Haddock flags
......
......@@ -449,6 +449,7 @@ output it generates.
QCONSYM { L _ (ITqconsym _) }
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
LABELVARID { L _ (ITlabelvarid _) }
CHAR { L _ (ITchar _ _) }
STRING { L _ (ITstring _ _) }
......@@ -2267,6 +2268,7 @@ aexp2 :: { LHsExpr RdrName }
: qvar { sL1 $1 (HsVar $! unLoc $1) }
| qcon { sL1 $1 (HsVar $! unLoc $1) }
| ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
| overloaded_label { sL1 $1 (HsOverLabel $! unLoc $1) }
| literal { sL1 $1 (HsLit $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
......@@ -2722,6 +2724,12 @@ dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3))
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
-----------------------------------------------------------------------------
-- Overloaded labels
overloaded_label :: { Located FastString }
: LABELVARID { sL1 $1 (getLABELVARID $1) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
......@@ -3141,6 +3149,7 @@ getQCONID (L _ (ITqconid x)) = x
getQVARSYM (L _ (ITqvarsym x)) = x
getQCONSYM (L _ (ITqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x
getLABELVARID (L _ (ITlabelvarid x)) = x
getCHAR (L _ (ITchar _ x)) = x
getSTRING (L _ (ITstring _ x)) = x
getINTEGER (L _ (ITinteger _ x)) = x
......
......@@ -321,6 +321,9 @@ basicKnownKeyNames
-- Type-level naturals
knownNatClassName, knownSymbolClassName,
-- Overloaded labels
isLabelClassName,
-- Source locations
callStackDataConName, callStackTyConName,
srcLocDataConName,
......@@ -478,6 +481,9 @@ gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
gHC_FINGERPRINT_TYPE :: Module
gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
gHC_OVER_LABELS :: Module
gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
mAIN, rOOT_MAIN :: Module
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
......@@ -1271,6 +1277,11 @@ knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam
knownSymbolClassName :: Name
knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
-- Overloaded labels
isLabelClassName :: Name
isLabelClassName
= clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
-- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName
......@@ -1407,6 +1418,9 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
isLabelClassNameKey :: Unique
isLabelClassNameKey = mkPreludeClassUnique 45
---------------- Template Haskell -------------------
-- THNames.hs: USES ClassUniques 200-299
-----------------------------------------------------
......@@ -2037,6 +2051,7 @@ toDynIdKey = mkPreludeMiscIdUnique 509
bitIntegerIdKey :: Unique
bitIntegerIdKey = mkPreludeMiscIdUnique 510
{-
************************************************************************
* *
......
......@@ -114,6 +114,9 @@ rnExpr (HsVar v)
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
rnExpr (HsOverLabel v)
= return (HsOverLabel v, emptyFVs)
rnExpr (HsLit lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
; if opt_OverloadedStrings then
......
......@@ -1150,9 +1150,12 @@ instance Outputable EvTypeable where
-- Helper functions for dealing with IP newtype-dictionaries
----------------------------------------------------------------------
-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary
-- to expose the underlying value. We expect the 'Type' to have the form
-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`.
-- | Create a 'Coercion' that unwraps an implicit-parameter or
-- overloaded-label dictionary to expose the underlying value. We
-- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`,
-- and return a 'Coercion' `co :: IP sym ty ~ ty` or
-- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also
-- Note [Type-checking overloaded labels] in TcExpr.
unwrapIP :: Type -> Coercion
unwrapIP ty =
case unwrapNewTyCon_maybe tc of
......
......@@ -57,6 +57,7 @@ import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import MkId ( proxyHashId )
import DynFlags
import SrcLoc
import Util
......@@ -212,6 +213,22 @@ tcExpr (HsIPVar x) res_ty
fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
unwrapIP $ mkClassPred ipClass [x,ty]
tcExpr (HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
= do { let origin = OverLabelOrigin l
; isLabelClass <- tcLookupClass isLabelClassName
; alpha <- newFlexiTyVarTy openTypeKind
; let lbl = mkStrLitTy l
pred = mkClassPred isLabelClass [lbl, alpha]
; loc <- getSrcSpanM
; var <- emitWanted origin pred
; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
(HsVar proxyHashId))
tm = L loc (fromDict pred (HsVar var)) `HsApp` proxy_arg
; tcWrapResult tm alpha res_ty }
where
-- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
fromDict pred = HsWrap $ mkWpCast $ TcCoercion $ unwrapIP pred
tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty
; return (mkHsWrap co_fn (HsLam match')) }
......@@ -252,6 +269,26 @@ tcExpr (HsType ty) _
-- Can't eliminate it altogether from the parser, because the
-- same parser parses *patterns*.
{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that (in GHC.OverloadedLabels) we have
class IsLabel (x :: Symbol) a where
fromLabel :: Proxy# x -> a
When we see an overloaded label like `#foo`, we generate a fresh
variable `alpha` for the type and emit an `IsLabel "foo" alpha`
constraint. Because the `IsLabel` class has a single method, it is
represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
`Proxy# "foo" -> alpha` (just like for implicit parameters). We then
apply it to `proxy#` of type `Proxy# "foo"`.
That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
-}
{-
************************************************************************
* *
......
......@@ -589,6 +589,9 @@ zonkExpr env (HsVar id)
zonkExpr _ (HsIPVar id)
= return (HsIPVar id)
zonkExpr _ (HsOverLabel l)
= return (HsOverLabel l)
zonkExpr env (HsLit (HsRat f ty))
= do new_ty <- zonkTcTypeToType env ty
return (HsLit (HsRat f new_ty))
......
......@@ -2215,6 +2215,7 @@ data CtOrigin
CtOrigin -- originally arising from this
| IPOccOrigin HsIPName -- Occurrence of an implicit parameter
| OverLabelOrigin FastString -- Occurrence of an overloaded label
| LiteralOrigin (HsOverLit Name) -- Occurrence of a literal
| NegateOrigin -- Occurrence of syntactic negation
......@@ -2324,6 +2325,8 @@ pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
pprCtO AppOrigin = ptext (sLit "an application")
pprCtO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
pprCtO (OverLabelOrigin l) = hsep [ptext (sLit "the overloaded label")
,quotes (char '#' <> ppr l)]
pprCtO RecordUpdOrigin = ptext (sLit "a record update")
pprCtO ExprSigOrigin = ptext (sLit "an expression type signature")
pprCtO PatSigOrigin = ptext (sLit "a pattern type signature")
......
{-# LANGUAGE NoImplicitPrelude
, MultiParamTypeClasses
, MagicHash
, KindSignatures
, DataKinds
#-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.OverloadedLabels
-- Copyright : (c) Adam Gundry 2015
-- License : see libraries/base/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC extensions)
--
-- This module defines the `IsLabel` class is used by the
-- OverloadedLabels extension. See the
-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page>
-- for more details.
--
-- The key idea is that when GHC sees an occurrence of the new
-- overloaded label syntax @#foo@, it is replaced with
--
-- > fromLabel (proxy# :: Proxy# "foo") :: alpha
--
-- plus a wanted constraint @IsLabel "foo" alpha@.
--
-----------------------------------------------------------------------------
-- Note [Overloaded labels]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-- An overloaded label is represented by the 'HsOverLabel' constructor
-- of 'HsExpr', which stores a 'FastString'. It is passed through
-- unchanged by the renamer, and the type-checker transforms it into a
-- call to 'fromLabel'. See Note [Type-checking overloaded labels] in
-- TcExpr for more details in how type-checking works.
module GHC.OverloadedLabels
( IsLabel(..)
) where
import GHC.Base ( Symbol )
import GHC.Exts ( Proxy# )
class IsLabel (x :: Symbol) a where
fromLabel :: Proxy# x -> a
......@@ -247,6 +247,7 @@ Library
GHC.Natural
GHC.Num
GHC.OldList
GHC.OverloadedLabels
GHC.PArr
GHC.Pack
GHC.Profiling
......
......@@ -32,7 +32,8 @@ check title expected got
expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional"]
"AlternativeLayoutRuleTransitional",
"OverloadedLabels"]
expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics",
......
test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
:set -XOverloadedLabels
:t #x
:m + GHC.OverloadedLabels
:seti -XFlexibleInstances -XFlexibleContexts -XTypeFamilies -XMultiParamTypeClasses
instance IsLabel x [Char] where fromLabel _ = "hello"
instance (s ~ [Char], t ~ [Char]) => IsLabel x (s -> t) where fromLabel _ = (++ " world")
#x :: String
#x #y
:{
#x
"goodbye"
:}
#x :: IsLabel "x" t => t
"hello"
"hello world"
"goodbye world"
......@@ -22,3 +22,4 @@ test('overloadedrecfldsfail12',
multimod_compile_fail, ['overloadedrecfldsfail12', ''])
test('overloadedrecfldsfail13', normal, compile_fail, [''])
test('overloadedrecfldsfail14', normal, compile_fail, [''])
test('overloadedlabelsfail01', normal, compile_fail, [''])
{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-}
import GHC.OverloadedLabels
-- No instance for (OverloadedLabel "x" t0)
a = #x
-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0)
b = #x #y
-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t)
c :: IsLabel "x" t => t
c = #y
main = return ()
overloadedlabelsfail01.hs:6:5: error:
No instance for (IsLabel "x" t2)
arising from the overloaded label ‘#x’
In the expression: #x
In an equation for ‘a’: a = #x
overloadedlabelsfail01.hs:9:5: error:
No instance for (IsLabel "x" (t0 -> t1))
arising from the overloaded label ‘#x’
(maybe you haven't applied a function to enough arguments?)
In the expression: #x
In the expression: #x #y
In an equation for ‘b’: b = #x #y
overloadedlabelsfail01.hs:9:8: error:
No instance for (IsLabel "y" t0)
arising from the overloaded label ‘#y’
In the first argument of ‘#x’, namely ‘#y’
In the expression: #x #y
In an equation for ‘b’: b = #x #y
overloadedlabelsfail01.hs:13:5: error:
Could not deduce (IsLabel "y" t)
arising from the overloaded label ‘#y’
from the context: IsLabel "x" t
bound by the type signature for:
c :: IsLabel "x" t => t
at overloadedlabelsfail01.hs:12:6-23
In the expression: #y
In an equation for ‘c’: c = #y
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-}
module OverloadedLabelsRun04_A where
import GHC.OverloadedLabels
import Language.Haskell.TH
instance IsLabel x (Q [Dec]) where
fromLabel _ = [d| main = putStrLn "Ok" |]
......@@ -8,3 +8,9 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
test('overloadedrecfldsrun04', normal, compile_and_run, [''])
test('overloadedrecfldsrun05', normal, compile_and_run, [''])
test('overloadedrecfldsrun06', normal, compile_and_run, [''])
test('overloadedlabelsrun01', normal, compile_and_run, [''])
test('overloadedlabelsrun02', normal, compile_and_run, [''])
test('overloadedlabelsrun03', normal, compile_and_run, [''])
test('overloadedlabelsrun04',
extra_clean(['OverloadedLabelsRun04_A.hi', 'OverloadedLabelsRun04_A.o']),
multimod_compile_and_run, ['overloadedlabelsrun04', ''])
-- Basic tests of overloaded labels
{-# LANGUAGE OverloadedLabels
, DataKinds
, FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, NoMonomorphismRestriction
#-}
import GHC.OverloadedLabels
instance IsLabel "true" Bool where
fromLabel _ = True
instance IsLabel "false" Bool where
fromLabel _ = False
a :: IsLabel "true" t => t
a = #true
b = #false
c :: Bool
c = #true
main = do print (a :: Bool)
print (b :: Bool)
print c
-- Using overloaded labels to provide nice syntactic sugar for a
-- term representation using de Bruijn indices
{-# LANGUAGE OverloadedLabels
, DataKinds
, FlexibleContexts
, FlexibleInstances
, GADTs
, KindSignatures
, MultiParamTypeClasses
, NoMonomorphismRestriction
, OverlappingInstances
, ScopedTypeVariables
, StandaloneDeriving
, TypeOperators
#-}
import GHC.OverloadedLabels
import Data.Proxy ( Proxy(..) )
import GHC.TypeLits ( Symbol )
instance x ~ y => IsLabel x (Proxy y) where
fromLabel _ = Proxy
data Elem (x :: Symbol) g where
Top :: Elem x (x ': g)
Pop :: Elem x g -> Elem x (y ': g)
deriving instance Show (Elem x g)
class IsElem x g where
which :: Elem x g
instance IsElem x (x ': g) where
which = Top
instance IsElem x g => IsElem x (y ': g) where
which = Pop which
data Tm g where
Var :: Elem x g -> Tm g
App :: Tm g -> Tm g -> Tm g
Lam :: Tm (x ': g) -> Tm g
deriving instance Show (Tm g)
instance IsElem x g => IsLabel x (Tm g) where
fromLabel _ = Var (which :: Elem x g)
lam :: Proxy x -> Tm (x ': g) -> Tm g
lam _ = Lam
s = lam #x #x
t = lam #x (lam #y (#x `App` #y))
u :: IsElem "z" g => Tm g
u = #z `App` #z
main = do print s
print t
print (u :: Tm '["z"])
Lam (Var Top)
Lam (Lam (App (Var (Pop Top)) (Var Top)))
App (Var Top) (Var Top)
-- Using overloaded labels as strings, slightly pointlessly
{-# LANGUAGE OverloadedLabels
, DataKinds
, FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, ScopedTypeVariables
, TypeFamilies
, TypeSynonymInstances
#-}
import GHC.OverloadedLabels
import Data.Proxy ( Proxy(..) )
import GHC.TypeLits ( KnownSymbol, symbolVal )
instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where
fromLabel _ = symbolVal (Proxy :: Proxy x)
main = do putStrLn #x
print $ #x ++ #y
{-# LANGUAGE OverloadedLabels, TemplateHaskell #-}
import OverloadedLabelsRun04_A
-- Who knew that there were so many ways that a line could start with
-- a # sign in Haskell? None of these are overloaded labels:
#line 7 "overloadedlabelsrun04.hs"
# 8 "overloadedlabelsrun04.hs"
#!notashellscript
#pragma foo
-- But this one is:
#foo
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment