Commit 52879d1f authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Reconstruct record expression in bidir pattern synonym

Reviewers: austin, rdragon, bgamari

Reviewed By: bgamari

Subscribers: rdragon, thomie

Differential Revision: https://phabricator.haskell.org/D1949
parent 66584914
......@@ -6,7 +6,9 @@
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
......@@ -244,9 +246,10 @@ data HsRecFields id arg -- A bunch of record fields
-- Used for both expressions and patterns
= HsRecFields { rec_flds :: [LHsRecField id arg],
rec_dotdot :: Maybe Int } -- Note [DotDot fields]
deriving (Typeable)
deriving (Typeable, Functor, Foldable, Traversable)
deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
-- Note [DotDot fields]
-- ~~~~~~~~~~~~~~~~~~~~
-- The rec_dotdot field means this:
......@@ -275,7 +278,7 @@ data HsRecField' id arg = HsRecField {
hsRecFieldLbl :: Located id,
hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning
hsRecPun :: Bool -- ^ Note [Punning]
} deriving (Data, Typeable)
} deriving (Data, Typeable, Functor, Foldable, Traversable)
-- Note [Punning]
......
......@@ -813,15 +813,30 @@ tcPatToExpr args = go
lhsVars = mkNameSet (map unLoc args)
go :: LPat Name -> Maybe (LHsExpr Name)
go (L loc (ConPatIn (L _ con) info))
= do { exprs <- mapM go (hsConPatArgs info)
; return $ L loc $
foldl (\x y -> HsApp (L loc x) y) (HsVar (L loc con)) exprs }
go (L loc (ConPatIn con info))
= case info of
PrefixCon ps -> mkPrefixConExpr con ps
InfixCon l r -> mkPrefixConExpr con [l,r]
RecCon fields -> L loc <$> mkRecordConExpr con fields
go (L _ (SigPatIn pat _)) = go pat
-- See Note [Type signatures and the builder expression]
go (L loc p) = fmap (L loc) $ go1 p
go (L loc p) = L loc <$> go1 p
-- Make a prefix con for prefix and infix patterns for simplicity
mkPrefixConExpr :: Located Name -> [LPat Name] -> Maybe (LHsExpr Name)
mkPrefixConExpr con pats = do
exprs <- traverse go pats
return $ foldl (\x y -> L (combineLocs x y) (HsApp x y))
(L (getLoc con) (HsVar con))
exprs
mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) -> Maybe (HsExpr Name)
mkRecordConExpr con fields = do
exprFields <- traverse go fields
return $ RecordCon con PlaceHolder noPostTcExpr exprFields
go1 :: Pat Name -> Maybe (HsExpr Name)
go1 (VarPat (L l var))
......
{-# LANGUAGE PatternSynonyms #-}
module T11633 where
data ARecord = ARecord {anInt :: Int, aString :: String}
-- This works...
pattern AGoodPat :: Int -> String -> ARecord
pattern AGoodPat n s = ARecord {anInt=n, aString=s}
pattern ABadPat :: Int -> String -> ARecord
pattern ABadPat n s = ARecord {aString=s, anInt=n}
......@@ -50,3 +50,4 @@ test('T11283', normal, compile, [''])
test('T11336', normal, compile, [''])
test('T11367', normal, compile, [''])
test('T11351', normal, compile, [''])
test('T11633', normal, compile, [''])
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