Commit 853efbfb authored by Shayne Fletcher's avatar Shayne Fletcher 🥝

Wip

parent bd75e5da
......@@ -3855,6 +3855,7 @@ xFlagsDeps = [
flagSpec "Rank2Types" LangExt.RankNTypes,
flagSpec "RankNTypes" LangExt.RankNTypes,
flagSpec "RebindableSyntax" LangExt.RebindableSyntax,
flagSpec "RecordDotSyntax" LangExt.RecordDotSyntax,
depFlagSpec' "RecordPuns" LangExt.RecordPuns
(deprecatedForExtension "NamedFieldPuns"),
flagSpec "RecordWildCards" LangExt.RecordWildCards,
......
......@@ -606,6 +606,19 @@ $tab { warnTab }
-- | | ordinary operator or type operator,
-- | | e.g. xs ~ 3, (~ x), Int ~ Bool
-- ----------+---------------+------------------------------------------
-- . | prefix | ITproj True
-- | | field projection,
-- | | e.g. .x
-- | tight infix | ITproj False
-- | | field projection,
-- | | e.g. r.x
-- | suffix | ITdot
-- | | function composition,
-- | | e.g. f. g
-- | loose infix | ITdot
-- | | function composition,
-- | | e.g. f . g
-- ----------+---------------+------------------------------------------
-- $ $$ | prefix | ITdollar, ITdollardollar
-- | | untyped or typed Template Haskell splice,
-- | | e.g. $(f x), $$(f x), $$"str"
......@@ -766,6 +779,7 @@ data Token
| ITtypeApp -- Prefix (@) only, e.g. f @t
| ITstar IsUnicodeSyntax
| ITdot
| ITproj Bool -- RecordDotSyntax
| ITbiglam -- GHC-extension symbols
......@@ -1452,6 +1466,9 @@ varsym_prefix = sym $ \exts s ->
-> return ITdollar
| ThQuotesBit `xtest` exts, s == fsLit "$$"
-> return ITdollardollar
| RecordDotSyntaxBit `xtest` exts, s == fsLit "."
-> return (ITproj True) -- e.g. '(.x)'
| s == fsLit "." -> return ITdot
| s == fsLit "!" -> return ITbang
| s == fsLit "~" -> return ITtilde
| otherwise -> return (ITvarsym s)
......@@ -1461,17 +1478,28 @@ varsym_suffix :: Action
varsym_suffix = sym $ \_ s ->
if | s == fsLit "@"
-> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
| s == fsLit "."
-> return ITdot
| otherwise -> return (ITvarsym s)
-- See Note [Whitespace-sensitive operator parsing]
varsym_tight_infix :: Action
varsym_tight_infix = sym $ \_ s ->
if | s == fsLit "@" -> return ITat
varsym_tight_infix = sym $ \exts s ->
if | s == fsLit "@"
-> return ITat
| RecordDotSyntaxBit `xtest` exts, s == fsLit "."
-> return (ITproj False)
| s == fsLit "."
-> return ITdot
| otherwise -> return (ITvarsym s)
-- See Note [Whitespace-sensitive operator parsing]
varsym_loose_infix :: Action
varsym_loose_infix = sym (\_ s -> return $ ITvarsym s)
varsym_loose_infix = sym $ \_ s ->
if | s == fsLit "."
-> return ITdot
| otherwise
-> return $ ITvarsym s
consym :: Action
consym = sym (\_exts s -> return $ ITconsym s)
......@@ -1479,8 +1507,13 @@ consym = sym (\_exts s -> return $ ITconsym s)
sym :: (ExtsBitmap -> FastString -> P Token) -> Action
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword, NormalSyntax, 0) ->
return $ L span keyword
Just (keyword, NormalSyntax, 0) -> do
exts <- getExts
if fs == fsLit "." &&
exts .&. (xbit RecordDotSyntaxBit) /= 0 &&
xtest RecordDotSyntaxBit exts
then L span <$!> con exts fs -- Process by varsym_*.
else return $ L span keyword
Just (keyword, NormalSyntax, i) -> do
exts <- getExts
if exts .&. i /= 0
......@@ -2468,6 +2501,8 @@ data ExtBits
| MultiWayIfBit
| GadtSyntaxBit
| ImportQualifiedPostBit
| RecordPunsBit
| RecordDotSyntaxBit
-- Flags that are updated once parsing starts
| InRulePragBit
......@@ -2555,6 +2590,8 @@ mkParserFlags' warningFlags extensionFlags thisPackage
.|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf
.|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax
.|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost
.|. RecordPunsBit `xoptBit` LangExt.RecordPuns
.|. RecordDotSyntaxBit `xoptBit` LangExt.RecordDotSyntax
optBits =
HaddockBit `setBitIf` isHaddock
.|. RawTokenStreamBit `setBitIf` rawTokStream
......
This diff is collapsed.
......@@ -17,6 +17,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
mkHsRecordUp',
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
......@@ -1809,7 +1810,6 @@ class b ~ (Body b) GhcPs => DisambECP b where
-- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
rejectPragmaPV :: Located b -> PV ()
{- Note [UndecidableSuperClasses for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(This Note is about the code in GHC, not about the user code that we are parsing)
......@@ -1962,6 +1962,12 @@ instance DisambECP (HsExpr GhcPs) where
hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
rejectPragmaPV _ = return ()
mkHsRecordUp' :: SrcSpan -> SrcSpan -> LHsExpr GhcPs -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> LHsExpr GhcPs
mkHsRecordUp' l lrec a (fbinds, ddLoc) =
L l (mkRecUpdate' a lrec (fbinds, ddLoc))
mkRecUpdate' exp _ (fs,dd) =
mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)
patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr item l e explanation =
do { addError l $
......
......@@ -144,4 +144,5 @@ data Extension
| ImportQualifiedPost
| CUSKs
| StandaloneKindSignatures
| RecordDotSyntax
deriving (Eq, Enum, Show, Generic, Bounded)
{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordDotSyntax #-}
-- Choice (C2a).
import Data.Function -- for &
class HasField x r a | x r -> a where
hasField :: r -> (a -> r, a)
getField :: forall x r a . HasField x r a => r -> a
getField = snd . hasField @x
setField :: forall x r a . HasField x r a => r -> a -> r
setField = fst . hasField @x
-- 'Foo' has 'foo' field of type 'Bar'
data Foo = Foo {foo :: Bar} deriving (Show, Eq)
instance HasField "foo" Foo Bar where
hasField r = (\x -> r{foo = x}, foo r)
-- 'Bar' has a 'bar' field of type 'Baz'
data Bar = Bar {bar :: Baz} deriving (Show, Eq)
instance HasField "bar" Bar Baz where
hasField r = (\x -> r{bar = x}, bar r)
-- 'Baz' has a 'baz' field of type 'Quux'
data Baz = Baz {baz :: Quux} deriving (Show, Eq)
instance HasField "baz" Baz Quux where
hasField r = (\x -> r{baz = x}, baz r)
-- 'Quux' has a 'quux' field of type 'Int'
data Quux = Quux {quux :: Int} deriving (Show, Eq)
instance HasField "quux" Quux Int where
hasField r = (\x -> r{quux = x}, quux r)
-- 'Corge' has a '&&&' field of type 'Int'
data Corge = Corge {(&&&) :: Int} deriving (Show, Eq)
instance HasField "&&&" Corge Int where
hasField r = (\x -> r{(&&&) = x}, (&&&) r)
-- Note : Dot notation is not available for fields with operator
-- names.
-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
instance HasField "f" Grault Foo where
hasField r = (\x -> r{f = x}, f r)
instance HasField "g" Grault Foo where
hasField r = (\x -> r{g = x}, g r)
main = do
let a = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 42}}}}
let b = Corge{(&&&) = 12};
let c = Grault {
f = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 1}}}}
, g = Foo {foo = Bar{bar = Baz {baz = Quux {quux = 1}}}}
}
-- A "selectors" is an expression like '(.a)' or '(.a.b)'.
putStrLn "-- selectors:"
print $ (.foo) a -- Bar {bar = Baz {baz = Quux {quux = 42}}}
print $ (.foo.bar) a -- Baz {baz = Quux {quux = 42}}
print $ (.foo.bar.baz) a -- Quux {quux = 42}
print $ (.foo.bar.baz.quux) a -- 42
print $ ((&&&) b) -- 12
-- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
print $ getField @"&&&" b -- 12
-- A "selection" is an expression like 'r.a' or '(f r).a.b'.
putStrLn "-- selections:"
print $ a.foo.bar.baz.quux -- 42
print $ a.foo.bar.baz -- Quux {quux = 42}
print $ a.foo.bar -- Baz {baz = Quux {quux = 42}}
print $ a.foo -- Bar {bar = Baz {baz = Quux {quux = 42}}}
print $ (const "hello") a.foo -- f r.x means f (r.x)
-- print $ f a .foo -- f r .x is illegal
print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x)
-- print $ f (g a) .foo -- f (g r) .x is illegal
print $ (a.foo.bar.baz) {quux = 2} -- Quux {quux = 2}
print $ a.foo
& (.bar.baz.quux) -- 42
add <- return (\x y -> x + y)
print $ add a.foo.bar.baz.quux 1 -- 43
print $ add (id a).foo.bar.baz.quux 1 -- 43
print $ add ((id a).foo.bar & (.baz.quux)) 1 -- 43
print $ (\b -> b{bar=Baz{baz=Quux{quux=1}}}) a.foo -- 1
-- An "update" is an expression like 'r{a.b = 12}'.
putStrLn "-- updates:"
print $ a{foo = Bar {bar = Baz {baz = Quux {quux = 44}}}} -- Top level update : Can NOT be a set_field expression!
print $ a{foo.bar = Baz {baz = Quux {quux = 44}}}
print $ a{foo.bar.baz = Quux {quux = 45}}
print $ a{foo.bar.baz.quux = 46}
print $ c{f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4}
-- A "punned update" is an expression like 'r{a.b}' (where it is
-- understood that 'b' is a variable binding in the environment of
-- the field update - enabled only when the extension
-- 'NamedFieldPuns' is in effect).
putStrLn "-- punned updates:"
let quux = 102; baz = Quux {quux}; bar = Baz {baz}; foo = Bar {bar}
print $ a{foo.bar.baz.quux}
print $ a{foo.bar.baz}
print $ a{foo.bar}
print $ a{foo} -- Top level update : Cannot be a set_field expression!
print $ a
print $ c{f.foo, g.foo.bar.baz.quux = 4} -- Mix punned and explicit.
f <- return a
g <- return a
print $ c{f} -- Ok
print $ c{f, g} -- Ok
-- print $ c{f, g.foo.bar.baz.quux = 4} -- illegal : Can't mix top-level and nested updates.
print $ c{f}{g.foo.bar.baz.quux = 4} -- Workaround
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