diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2017-07-11 19:01:31 +0100 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2017-07-11 19:02:44 +0100 |
| commit | 81de42cb589540666a365808318589211924f9cd (patch) | |
| tree | 83c4c361404260b5aa3d0792392d9ed09f18388e /compiler | |
| parent | ccb849f8ea39582d2cfc5c045abe9768992dccb6 (diff) | |
| download | haskell-81de42cb589540666a365808318589211924f9cd.tar.gz | |
Add Template Haskell support for overloaded labels
Reviewers: RyanGlScott, austin, goldfire, bgamari
Reviewed By: RyanGlScott, goldfire, bgamari
Subscribers: rwbarton, thomie
Differential Revision: https://phabricator.haskell.org/D3715
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 8 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 1 | ||||
| -rw-r--r-- | compiler/prelude/THNames.hs | 8 |
3 files changed, 14 insertions, 3 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d23ac3894a..c6799813df 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1171,7 +1171,7 @@ repE (HsVar (L _ 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 (HsOverLabel _ s) = repOverLabel s repE e@(HsRecFld f) = case f of Unambiguous _ x -> repE (HsVar (noLoc x)) @@ -2459,6 +2459,12 @@ repSequenceQ ty_a (MkC list) repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ) repUnboundVar (MkC name) = rep2 unboundVarEName [name] +repOverLabel :: FastString -> DsM (Core TH.ExpQ) +repOverLabel fs = do + (MkC s) <- coreStringLit $ unpackFS fs + rep2 labelEName [s] + + ------------ Lists ------------------- -- turn a list of patterns into a single pattern matching a list diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 8fc903bb5a..de36a85937 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -864,6 +864,7 @@ cvtl e = wrapL (cvt e) ; return $ mkRdrRecordUpd e' flds' } cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 9502e9e654..85362434cc 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -54,6 +54,7 @@ templateHaskellNames = [ condEName, multiIfEName, letEName, caseEName, doEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, + labelEName, -- FieldExp fieldExpName, -- Body @@ -278,7 +279,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, - caseEName, doEName, compEName, staticEName, unboundVarEName :: Name + caseEName, doEName, compEName, staticEName, unboundVarEName, + labelEName :: Name varEName = libFun (fsLit "varE") varEIdKey conEName = libFun (fsLit "conE") conEIdKey litEName = libFun (fsLit "litE") litEIdKey @@ -313,6 +315,7 @@ recConEName = libFun (fsLit "recConE") recConEIdKey recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey staticEName = libFun (fsLit "staticE") staticEIdKey unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey +labelEName = libFun (fsLit "labelE") labelEIdKey -- type FieldExp = ... fieldExpName :: Name @@ -804,7 +807,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, - unboundVarEIdKey :: Unique + unboundVarEIdKey, labelEIdKey :: Unique varEIdKey = mkPreludeMiscIdUnique 270 conEIdKey = mkPreludeMiscIdUnique 271 litEIdKey = mkPreludeMiscIdUnique 272 @@ -835,6 +838,7 @@ recConEIdKey = mkPreludeMiscIdUnique 296 recUpdEIdKey = mkPreludeMiscIdUnique 297 staticEIdKey = mkPreludeMiscIdUnique 298 unboundVarEIdKey = mkPreludeMiscIdUnique 299 +labelEIdKey = mkPreludeMiscIdUnique 300 -- type FieldExp = ... fieldExpIdKey :: Unique |