Parse 'record', 'variant' and 'enum' after 'data', adding the corresp…

…onding Data{Record,Variant,Enum} constraint to the data type dumb theta
digital-asset · Mar 27, 2024 · 83673a9 · 83673a9
1 parent c038210
commit 83673a9
Show file tree

Hide file tree

Showing 2 changed files with 60 additions and 0 deletions.
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
@@ -1392,6 +1392,16 @@ ty_decl :: { LTyClDecl GhcPs }
                                    -- constrs and deriving are both empty
                         ((fst $ unLoc $1):(fst $ unLoc $4)) }
 
+          -- flavored data type or newtype declaration
+          -- (can't use e.g. opt_data_flavor on the above because you get reduce/reduce errors)
+        | data_or_newtype data_flavor capi_ctype tycl_hdr constrs maybe_derivings
+                {% amms (mkFlavoredTyData (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $2 $3 $4
+                           Nothing (reverse (snd $ unLoc $5))
+                                   (fmap reverse $6))
+                                   -- We need the location on tycl_hdr in case
+                                   -- constrs and deriving are both empty
+                        ((fst $ unLoc $1):(fst $ unLoc $5)) }
+
           -- ordinary GADT declaration
         | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
@@ -1633,6 +1643,11 @@ data_or_newtype :: { Located (AddAnn, NewOrData) }
         : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
         | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }
 
+data_flavor :: { Located DataFlavor }
+        : 'record'  { sL1 $1 FlavorRecord }
+        | 'variant' { sL1 $1 FlavorVariant }
+        | 'enum'    { sL1 $1 FlavorEnum }
+
 -- Family result/return kind signatures
 
 opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) }

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
@@ -66,6 +66,10 @@ module   RdrHsSyn (
         ValidInterfaceInstanceMethodDecl(..),
         ghcTypesDamlInterface,
 
+        -- Daml data syntax
+        DataFlavor(..),
+        mkFlavoredTyData,
+
         -- DAML name utilities
         qualifyDesugar,
         isDamlGenerated,
@@ -253,6 +257,47 @@ mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
 mkATDefault _ = panic "mkATDefault: Impossible Match"
                                 -- due to #15884
 
+data DataFlavor
+  = FlavorRecord
+  | FlavorVariant
+  | FlavorEnum
+
+dataFlavorToCxt :: Located DataFlavor -> LHsContext GhcPs
+dataFlavorToCxt (L loc flavor) =
+  L loc [rdrNameToType . L loc . qualifyDesugar . mkClsOcc $ flavorString]
+  where
+    flavorString = case flavor of
+      FlavorRecord -> "DataRecord"
+      FlavorVariant -> "DataVariant"
+      FlavorEnum -> "DataEnum"
+
+mergeCxt :: LHsContext GhcPs -> LHsContext GhcPs -> LHsContext GhcPs
+mergeCxt (L lloc lcxt) (L rloc rcxt) =
+  L (combineSrcSpans lloc rloc) (lcxt ++ rcxt)
+
+mkFlavoredTyData ::
+     SrcSpan
+  -> NewOrData
+  -> Located DataFlavor
+  -> Maybe (Located CType)
+  -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
+  -> Maybe (LHsKind GhcPs)
+  -> [LConDecl GhcPs]
+  -> HsDeriving GhcPs
+  -> P (LTyClDecl GhcPs)
+mkFlavoredTyData loc DataType flavor cType hdr' =
+  mkTyData loc DataType cType hdr
+  where
+    L hdrLoc (mCxt, tycl_hdr) = hdr'
+    flavorCxt = dataFlavorToCxt flavor
+    fullCxt = case mCxt of
+      Nothing -> flavorCxt
+      Just userCxt -> mergeCxt userCxt flavorCxt
+    hdr = L hdrLoc (Just fullCxt, tycl_hdr)
+mkFlavoredTyData loc NewType _ _ _ =
+  \_ _ _ -> parseErrorSDoc loc $
+      text "Newtypes with explicit data type representation are disallowed."
+
 mkTyData :: SrcSpan
          -> NewOrData
          -> Maybe (Located CType)