Pattern matching for RoundingMode (#9381)

* Pattern matching for RoundingMode

- Fix the order of RoundingMode constructors in GHC.Types to match the LF built-in order. Try to match this order across all code and documentation, and added a test for this order.
- Implements pattern matching for RoundingMode. The added machinery could also be useful for solving #5753 in the future.
- Implements Show instance for RoundingMode. (Mainly so we can use them in tests.) Moved BigNumeric Show instance to GHC.Show.

changelog_begin
changelog_end

* mkScrutineeEquality typo

* fix roundingModeLiteralMap order

* Use custom type for building case body

* Factor GeneralisedCaseAlternative into GeneralisedCasePattern

* Fix finalize

* Remove unused bindings

compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Pretty.hs

@@ -204,14 +204,15 @@ instance Pretty PartyLiteral where
   pPrint = quotes . text . unPartyLiteral
 
 prettyRounding :: RoundingModeLiteral -> String
-prettyRounding LitRoundingUp = "ROUNDING_UP"
-prettyRounding LitRoundingDown = "ROUNDING_DOWN"
-prettyRounding LitRoundingCeiling = "ROUNDING_CEILING"
-prettyRounding LitRoundingFloor = "ROUNDING_FLOOR"
-prettyRounding LitRoundingHalfUp = "ROUNDING_HALF_UP"
-prettyRounding LitRoundingHalfDown = "ROUNDING_HALF_DOWN"
-prettyRounding LitRoundingHalfEven = "ROUNDING_HALF_EVEN"
-prettyRounding LitRoundingUnnecessary = "ROUNDING_UNNECESSARY"
+prettyRounding = \case
+  LitRoundingUp -> "ROUNDING_UP"
+  LitRoundingDown -> "ROUNDING_DOWN"
+  LitRoundingCeiling -> "ROUNDING_CEILING"
+  LitRoundingFloor -> "ROUNDING_FLOOR"
+  LitRoundingHalfUp -> "ROUNDING_HALF_UP"
+  LitRoundingHalfDown -> "ROUNDING_HALF_DOWN"
+  LitRoundingHalfEven -> "ROUNDING_HALF_EVEN"
+  LitRoundingUnnecessary -> "ROUNDING_UNNECESSARY"
 
 instance Pretty BuiltinExpr where
   pPrintPrec lvl prec = \case

compiler/daml-lf-proto/src/DA/Daml/LF/Proto3/DecodeV1.hs

@@ -770,8 +770,8 @@ decodePrimLit (LF1.PrimLit mbSum) = mayDecode "primLitSum" mbSum $ \case
     Proto.Enumerated (Right mode) -> pure $ case mode of
        LF1.PrimLit_RoundingModeUP -> BERoundingMode LitRoundingUp
        LF1.PrimLit_RoundingModeDOWN -> BERoundingMode LitRoundingDown
-       LF1.PrimLit_RoundingModeFLOOR -> BERoundingMode LitRoundingFloor
        LF1.PrimLit_RoundingModeCEILING -> BERoundingMode LitRoundingCeiling
+       LF1.PrimLit_RoundingModeFLOOR -> BERoundingMode LitRoundingFloor
        LF1.PrimLit_RoundingModeHALF_UP -> BERoundingMode LitRoundingHalfUp
        LF1.PrimLit_RoundingModeHALF_DOWN -> BERoundingMode LitRoundingHalfDown
        LF1.PrimLit_RoundingModeHALF_EVEN -> BERoundingMode LitRoundingHalfEven

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs

@@ -1144,14 +1144,8 @@ convertExpr env0 e = do
 
     go env (VarIn GHC_Tuple "()") args = pure (EUnit, args)
 
-    go env (VarIn GHC_Types "RoundingCeiling"    ) args = pure (EBuiltin (BERoundingMode LitRoundingCeiling    ), args)
-    go env (VarIn GHC_Types "RoundingFloor"      ) args = pure (EBuiltin (BERoundingMode LitRoundingFloor      ), args)
-    go env (VarIn GHC_Types "RoundingDown"       ) args = pure (EBuiltin (BERoundingMode LitRoundingDown       ), args)
-    go env (VarIn GHC_Types "RoundingUp"         ) args = pure (EBuiltin (BERoundingMode LitRoundingUp         ), args)
-    go env (VarIn GHC_Types "RoundingHalfDown"   ) args = pure (EBuiltin (BERoundingMode LitRoundingHalfDown   ), args)
-    go env (VarIn GHC_Types "RoundingHalfEven"   ) args = pure (EBuiltin (BERoundingMode LitRoundingHalfEven   ), args)
-    go env (VarIn GHC_Types "RoundingHalfUp"     ) args = pure (EBuiltin (BERoundingMode LitRoundingHalfUp     ), args)
-    go env (VarIn GHC_Types "RoundingUnnecessary") args = pure (EBuiltin (BERoundingMode LitRoundingUnnecessary), args)
+    go env (VarIn GHC_Types (RoundingModeName roundingModeLit)) args =
+        pure (EBuiltin (BERoundingMode roundingModeLit), args)
 
     go env (VarIn GHC_Types "True") args = pure (mkBool True, args)
     go env (VarIn GHC_Types "False") args = pure (mkBool False, args)
@@ -1208,8 +1202,9 @@ convertExpr env0 e = do
             let fldName = fldNames !! fldIndex
             recTyp <- convertType env (varType bind)
             pure $ mkDictProj env (fromTCon recTyp) fldName scrutinee' `ETmApp` EUnit
-    go env o@(Case scrutinee bind _ [alt@(DataAlt con, vs, x)]) args = fmap (, args) $ do
+    go env o@(Case scrutinee bind resultType [alt@(DataAlt con, vs, x)]) args = fmap (, args) $ do
         convertType env (varType bind) >>= \case
+            -- opaque types have no patterns that can be matched
             TText -> asLet
             TDecimal -> asLet
             TNumeric _ -> asLet
@@ -1233,32 +1228,96 @@ convertExpr env0 e = do
                     bind' <- convertExpr env (Var bind)
                     ty <- convertType env $ varType bind
                     alt' <- convertAlt env ty alt
-                    pure $ ECase bind' [alt']
+                    resultType' <- convertType env resultType
+                    pure $ mkCase env ty resultType' bind' [alt']
 
       where
         asLet = convertLet env bind scrutinee $ \env -> convertExpr env x
-    go env (Case scrutinee bind typ []) args = fmap (, args) $ do
-        -- GHC only generates empty case alternatives if it is sure the scrutinee will fail, LF doesn't support empty alternatives
-        scrutinee' <- convertExpr env scrutinee
-        typ' <- convertType env typ
-        bind' <- convVarWithType env bind
-        pure $
-          ELet (Binding bind' scrutinee') $
-          ECase (EVar $ convVar bind) [CaseAlternative CPDefault $ EBuiltin BEError `ETyApp` typ' `ETmApp` EBuiltin (BEText "Unreachable")]
-    go env (Case scrutinee bind _ (defaultLast -> alts)) args = fmap (, args) $ do
+    go env (Case scrutinee bind resultType (defaultLast -> alts)) args = fmap (, args) $ do
         scrutinee' <- convertExpr env scrutinee
         bindTy <- convertType env $ varType bind
         alts' <- mapM (convertAlt env bindTy) alts
         bind' <- convVarWithType env bind
-        if isDeadOcc (occInfo (idInfo bind))
-          then pure $ ECase scrutinee' alts'
-          else pure $
+        resultType' <- convertType env resultType
+        if isDeadOcc (occInfo (idInfo bind)) && all isNormalCaseAlternative alts'
+        then pure $ mkCase env bindTy resultType' scrutinee' alts'
+        else pure $
             ELet (Binding bind' scrutinee') $
-            ECase (EVar $ convVar bind) alts'
+            mkCase env bindTy resultType' (EVar $ convVar bind) alts'
     go env (Let (Rec xs) _) args = unsupported "Local variables defined recursively - recursion can only happen at the top level" $ map fst xs
     go env o@(Coercion _) args = unhandled "Coercion" o
     go _ x args = unhandled "Expression" x
 
+-- | Represents a generalised case pattern for a generalised case alternative.
+data GeneralisedCasePattern
+    = GCPEquality LF.Expr
+        -- ^ Pattern matching via built-in equality.
+    | GCPNormal CasePattern
+        -- ^ Normal case alternative that is directly supported by LF.
+        -- This includes the default case (CPDefault).
+    deriving (Eq, Ord)
+
+-- | Generalised case alternative
+data GeneralisedCaseAlternative = GCA GeneralisedCasePattern LF.Expr
+    deriving (Eq, Ord)
+
+-- | Is this a normal case alternative?
+isNormalCaseAlternative :: GeneralisedCaseAlternative -> Bool
+isNormalCaseAlternative = \case
+    GCA (GCPNormal _) _ -> True
+    _ -> False
+
+-- | Represents the body of a generalised case expression.
+data GeneralisedCaseBody
+    = GCBExpr LF.Expr
+        -- ^ Expression representing the generalised case.
+    | GCBAlts [CaseAlternative]
+        -- ^ Alternatives for a regular case statement.
+
+-- | Make a case expression from GeneralisedCaseAlternatives.
+--
+-- The scrutinee will be evaluated multiple times unless all the
+-- case alternatives are normal case alternatives. So to prevent
+-- this, this function should only be used when either the scrutinee
+-- is inert (e.g. a bound variable), or all the alternatives are
+-- normal case alternatives ('GCANormal').
+mkCase :: Env -> LF.Type -> LF.Type -> LF.Expr -> [GeneralisedCaseAlternative] -> LF.Expr
+mkCase env scrutineeType resultType scrutinee galts =
+    finalize (foldr addCaseAlternative (GCBAlts []) galts)
+  where
+    finalize :: GeneralisedCaseBody -> LF.Expr
+    finalize = \case
+        GCBExpr e -> e
+        GCBAlts [] ->
+            ECase scrutinee
+                [ CaseAlternative CPDefault
+                $ EBuiltin BEError
+                    `ETyApp` resultType
+                    `ETmApp` EBuiltin (BEText "Unreachable") ]
+                -- GHC only generates empty case alternatives if it is sure the scrutinee will fail.
+                -- LF doesn't support empty alternatives, so we turn this into a non-empty alternative.
+        GCBAlts alts ->
+            ECase scrutinee alts
+
+    addCaseAlternative :: GeneralisedCaseAlternative -> GeneralisedCaseBody -> GeneralisedCaseBody
+    addCaseAlternative (GCA (GCPNormal pattern) rhs) (GCBAlts alts) =
+        GCBAlts (CaseAlternative pattern rhs : alts)
+    addCaseAlternative (GCA (GCPNormal pattern) rhs) (GCBExpr e) =
+        GCBAlts [CaseAlternative pattern rhs, CaseAlternative CPDefault e]
+    addCaseAlternative (GCA (GCPEquality expr) rhs) elseBranch =
+        GCBExpr (mkIf (mkScrutineeEquality expr) rhs (finalize elseBranch))
+
+    mkScrutineeEquality :: LF.Expr -> LF.Expr
+    mkScrutineeEquality pattern
+        | TBuiltin scrutineeBuiltinType <- scrutineeType
+        = mkBuiltinEqual (envLfVersion env) scrutineeBuiltinType `ETmApp` scrutinee `ETmApp` pattern
+
+        | envLfVersion env `supports` featureGenericComparison
+        = EBuiltin BEEqualGeneric `ETyApp` scrutineeType `ETmApp` scrutinee `ETmApp` pattern
+
+        | otherwise
+        = error "mkScrutineeEquality: No built-in equality exists for target LF version and type."
+
 -- | Is this a constraint tuple?
 isConstraintTupleTyCon :: TyCon -> Bool
 isConstraintTupleTyCon = (Just ConstraintTuple ==) . tyConTuple_maybe
@@ -1441,20 +1500,27 @@ convertUnitId _thisUnitId pkgMap unitId = case unitId of
     Just DalfPackage{..} -> pure $ LF.PRImport dalfPackageId
     Nothing -> unknown unitId pkgMap
 
-convertAlt :: Env -> LF.Type -> Alt Var -> ConvertM CaseAlternative
-convertAlt env ty (DEFAULT, [], x) = CaseAlternative CPDefault <$> convertExpr env x
+convertAlt :: Env -> LF.Type -> Alt Var -> ConvertM GeneralisedCaseAlternative
+convertAlt env ty (DEFAULT, [], x) = GCA (GCPNormal CPDefault) <$> convertExpr env x
 convertAlt env ty (DataAlt con, [], x)
-    | NameIn GHC_Types "True" <- con = CaseAlternative (CPBool True) <$> convertExpr env x
-    | NameIn GHC_Types "False" <- con = CaseAlternative (CPBool False) <$> convertExpr env x
-    | NameIn GHC_Types "[]" <- con = CaseAlternative CPNil <$> convertExpr env x
-    | NameIn GHC_Tuple "()" <- con = CaseAlternative CPUnit <$> convertExpr env x
+    | NameIn GHC_Types "True" <- con = GCA (GCPNormal (CPBool True)) <$> convertExpr env x
+    | NameIn GHC_Types "False" <- con = GCA (GCPNormal (CPBool False)) <$> convertExpr env x
+    | NameIn GHC_Types "[]" <- con = GCA (GCPNormal CPNil) <$> convertExpr env x
+    | NameIn GHC_Tuple "()" <- con = GCA (GCPNormal CPUnit) <$> convertExpr env x
     | NameIn DA_Internal_Prelude "None" <- con
-    = CaseAlternative CPNone <$> convertExpr env x
+    = GCA (GCPNormal CPNone) <$> convertExpr env x
+
+    -- Rounding mode constructors do not have built-in LF support for pattern matching,
+    -- but we get the same result with equality tests.
+    | NameIn GHC_Types (RoundingModeName roundingModeLit) <- con
+    = GCA (GCPEquality (EBuiltin (BERoundingMode roundingModeLit))) <$> convertExpr env x
+
 convertAlt env ty (DataAlt con, [a,b], x)
-    | NameIn GHC_Types ":" <- con = CaseAlternative (CPCons (convVar a) (convVar b)) <$> convertExpr env x
+    | NameIn GHC_Types ":" <- con
+    = GCA (GCPNormal (CPCons (convVar a) (convVar b))) <$> convertExpr env x
 convertAlt env ty (DataAlt con, [a], x)
     | NameIn DA_Internal_Prelude "Some" <- con
-    = CaseAlternative (CPSome (convVar a)) <$> convertExpr env x
+    = GCA (GCPNormal (CPSome (convVar a))) <$> convertExpr env x
 
 convertAlt env (TConApp tcon targs) alt@(DataAlt con, vs, x) = do
     let patTypeCon = tcon
@@ -1463,7 +1529,7 @@ convertAlt env (TConApp tcon targs) alt@(DataAlt con, vs, x) = do
 
     case classifyDataCon con of
         EnumCon ->
-            CaseAlternative (CPEnum patTypeCon patVariant) <$> convertExpr env x
+            GCA (GCPNormal (CPEnum patTypeCon patVariant)) <$> convertExpr env x
 
         SimpleVariantCon -> do
             when (length vs /= dataConRepArity con) $
@@ -1472,7 +1538,7 @@ convertAlt env (TConApp tcon targs) alt@(DataAlt con, vs, x) = do
                 unsupported "Data constructor with multiple unnamed fields" alt
 
             let patBinder = maybe vArg convVar (listToMaybe vs)
-            CaseAlternative CPVariant{..} <$> convertExpr env x
+            GCA (GCPNormal CPVariant{..}) <$> convertExpr env x
 
         SimpleRecordCon ->
             unhandled "unreachable case -- convertAlt with simple record constructor" ()
@@ -1485,10 +1551,7 @@ convertAlt env (TConApp tcon targs) alt@(DataAlt con, vs, x) = do
                 Just vsFlds -> do
                     x' <- convertExpr env x
                     projBinds <- mkProjBindings env (EVar vArg) (TypeConApp (synthesizeVariantRecord patVariant <$> tcon) targs) vsFlds x'
-                    pure $ CaseAlternative CPVariant{..} projBinds
-
-convertAlt _ TRoundingMode alt@(DataAlt con, _, _) = do
-    unsupported "Pattern matching on RoundingMode is not currently supported. Please use (==) instead" con
+                    pure $ GCA (GCPNormal CPVariant{..}) projBinds
 
 convertAlt _ _ x = unsupported "Case alternative of this form" x
 
@@ -1734,7 +1797,6 @@ convertTyCon env t
             "BigNumeric" -> pure TBigNumeric
             "RoundingMode" -> pure TRoundingMode
             _ -> defaultTyCon
-    -- TODO(DEL-6953): We need to add a condition on the package name as well.
     | NameIn DA_Internal_LF n <- t =
         case n of
             "Scenario" -> pure (TBuiltin BTScenario)
@@ -1965,6 +2027,7 @@ convVar = mkVar . varPrettyPrint
 
 convVarWithType :: Env -> Var -> ConvertM (ExprVarName, LF.Type)
 convVarWithType env v = (convVar v,) <$> convertType env (varType v)
+
 convVal :: Var -> ExprValName
 convVal = mkVal . varPrettyPrint
 

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/Primitives.hs

@@ -437,31 +437,6 @@ convertPrim _ "UTryCatch" ((TUnit :-> TUpdate t1) :-> (TBuiltin BTAnyException :
             (mkVar "x")
             (EVar (mkVar "c") `ETmApp` EVar (mkVar "x"))
 
-convertPrim version "BERoundingUp" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingUp
-convertPrim version "BERoundingDown" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingDown
-convertPrim version "BERoundingCeiling" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingCeiling
-convertPrim version "BERoundingFloor" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingFloor
-convertPrim version "BERoundingHalfUp" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingHalfUp
-convertPrim version "BERoundingHalfDown" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingHalfDown
-convertPrim version "BERoundingHalfEven" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingHalfEven
-convertPrim version "BERoundingUnnecessary" TRoundingMode =
-    whenRuntimeSupports version featureBigNumeric TRoundingMode $
-      EBuiltin $ BERoundingMode LitRoundingUnnecessary
-
 convertPrim (V1 PointDev) (L.stripPrefix "$" -> Just builtin) typ =
     EExperimental (T.pack builtin) typ
 

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilGHC.hs

@@ -22,8 +22,6 @@ import "ghc-lib-parser" Class as GHC
 
 import Data.Generics.Uniplate.Data
 import Data.Maybe
-import Data.List
-import Data.Tuple.Extra
 import qualified Data.ByteString as BS
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -32,7 +30,8 @@ import GHC.Ptr(Ptr(..))
 import System.IO.Unsafe
 import Text.Read (readMaybe)
 import Control.Monad (guard)
-
+import qualified Data.Map.Strict as MS
+import qualified DA.Daml.LF.Ast as LF
 
 ----------------------------------------------------------------------
 -- GHC utility functions
@@ -192,6 +191,23 @@ pattern ConstraintTupleProjection :: Int -> Int -> GHC.Expr Var
 pattern ConstraintTupleProjection index arity <-
     Var (ConstraintTupleProjectionName index arity)
 
+pattern RoundingModeName :: LF.RoundingModeLiteral -> FastString
+pattern RoundingModeName lit <- (toRoundingModeLiteral . fsToText -> Just lit)
+
+toRoundingModeLiteral :: T.Text -> Maybe LF.RoundingModeLiteral
+toRoundingModeLiteral x = MS.lookup x roundingModeLiteralMap
+
+roundingModeLiteralMap :: MS.Map T.Text LF.RoundingModeLiteral
+roundingModeLiteralMap = MS.fromList
+    [ ("RoundingUp", LF.LitRoundingUp)
+    , ("RoundingDown", LF.LitRoundingDown)
+    , ("RoundingCeiling", LF.LitRoundingCeiling)
+    , ("RoundingFloor", LF.LitRoundingFloor)
+    , ("RoundingHalfUp", LF.LitRoundingHalfUp)
+    , ("RoundingHalfDown", LF.LitRoundingHalfDown)
+    , ("RoundingHalfEven", LF.LitRoundingHalfEven)
+    , ("RoundingUnnecessary", LF.LitRoundingUnnecessary)
+    ]
 
 subst :: [(TyVar, GHC.Type)] -> GHC.Type -> GHC.Type
 subst env = transform $ \t ->
@@ -243,12 +259,16 @@ hasDamlExceptionCtx t
 varPrettyPrint :: Var -> T.Text
 varPrettyPrint (varName -> x) = getOccText x <> (if isSystemName x then "_" <> T.pack (show $ nameUnique x) else "")
 
+-- | Move DEFAULT case to end of the alternatives list.
+--
+-- GHC always puts the DEFAULT case at the front of the list
+-- (see https://hackage.haskell.org/package/ghc-8.2.2/docs/CoreSyn.html#t:Expr).
+-- We move the DEFAULT case to the back because LF gives earlier
+-- patterns priority, so the DEFAULT case needs to be last.
 defaultLast :: [Alt Var] -> [Alt Var]
-defaultLast = uncurry (++) . partition ((/=) DEFAULT . fst3)
-
-isLitAlt :: Alt Var -> Bool
-isLitAlt (LitAlt{},_,_) = True
-isLitAlt _              = False
+defaultLast = \case
+    alt@(DEFAULT,_,_) : alts -> alts ++ [alt]
+    alts -> alts
 
 untick :: GHC.Expr b -> GHC.Expr b
 untick = \case

compiler/damlc/daml-prim-src/GHC/Num.daml

@@ -25,7 +25,6 @@ import GHC.CString (fromString)
 import GHC.Err (error)
 import GHC.Integer.Type
 import GHC.Real
-import GHC.Show
 import GHC.Types
 
 default ()              -- Double isn't available yet,
@@ -177,9 +176,6 @@ instance Signed BigNumeric where
     signum x = if x == aunit then aunit else if x <= aunit then negate munit else munit
     abs x = if x <= aunit then negate x else x
 
-instance Show BigNumeric where
-    show = primitive @"BEToTextBigNumeric"
-
 #endif
 
 -- | Use the `Divisible` class for types that can be divided.

compiler/damlc/daml-prim-src/GHC/Show.daml

@@ -122,6 +122,21 @@ instance Show Decimal where
   show = primitive @"BEToText"
 #endif
 
+#ifdef DAML_BIGNUMERIC
+instance Show BigNumeric where
+  show = primitive @"BEToTextBigNumeric"
+instance Show RoundingMode where
+  show = \case
+    RoundingUp -> "RoundingUp"
+    RoundingDown -> "RoundingDown"
+    RoundingCeiling -> "RoundingCeiling"
+    RoundingFloor -> "RoundingFloor"
+    RoundingHalfUp -> "RoundingHalfUp"
+    RoundingHalfDown -> "RoundingHalfDown"
+    RoundingHalfEven -> "RoundingHalfEven"
+    RoundingUnnecessary -> "RoundingUnnecessary"
+#endif
+
 instance Show Text where
   show x = "\"" ++ x ++ "\""
 

compiler/damlc/daml-prim-src/GHC/Types.daml

@@ -224,19 +224,19 @@ data BigNumeric =
 
 -- | Rounding modes for `BigNumeric` operations like `div` and `round` from `DA.BigNumeric`.
 data RoundingMode
-  = RoundingCeiling -- ^ Round towards positive infinity.
-  | RoundingFloor -- ^ Round towards negative infinity.
+  = RoundingUp -- ^ Round away from zero.
   | RoundingDown -- ^ Round towards zero.
-  | RoundingUp -- ^ Round away from zero.
+  | RoundingCeiling -- ^ Round towards positive infinity.
+  | RoundingFloor -- ^ Round towards negative infinity.
+  | RoundingHalfUp
+      -- ^ Round towards the nearest neighbor unless both neighbors
+      -- are equidistant, in which case round away from zero.
   | RoundingHalfDown
       -- ^ Round towards the nearest neighbor unless both neighbors
       -- are equidistant, in which case round towards zero.
   | RoundingHalfEven
       -- ^ Round towards the nearest neighbor unless both neighbors
       -- are equidistant, in which case round towards the even neighbor.
-  | RoundingHalfUp
-      -- ^ Round towards the nearest neighbor unless both neighbors
-      -- are equidistant, in which case round away from zero.
   | RoundingUnnecessary
       -- ^ Do not round. Raises an error if the result cannot
       -- be represented without rounding at the targeted scale.

compiler/damlc/tests/daml-test-files/RoundingModeMatch.daml

@@ -3,10 +3,28 @@
 
 -- @SINCE-LF 1.13
 
--- | Test that you get errors when trying to pattern match on rounding mode.
+-- | Test that pattern matching for RoundingMode works.
 module RoundingModeMatch where
 
--- @ERROR Pattern matching on RoundingMode is not currently supported
+import DA.Assert ((===))
+
 foo : RoundingMode -> Int
-foo RoundingCeiling = 10
-foo _ = 20
+foo = \case
+    RoundingUp -> 1
+    RoundingDown -> 2
+    RoundingCeiling -> 3
+    RoundingFloor -> 4
+    RoundingHalfUp -> 5
+    RoundingHalfDown -> 6
+    RoundingHalfEven -> 7
+    RoundingUnnecessary -> 8
+
+test = scenario do
+    foo RoundingUp === 1
+    foo RoundingDown === 2
+    foo RoundingCeiling === 3
+    foo RoundingFloor === 4
+    foo RoundingHalfUp === 5
+    foo RoundingHalfDown === 6
+    foo RoundingHalfEven === 7
+    foo RoundingUnnecessary === 8

compiler/damlc/tests/daml-test-files/RoundingModeOrder.daml

@@ -0,0 +1,28 @@
+-- Copyright (c) 2021, Digital Asset (Switzerland) GmbH and/or its affiliates.
+-- All rights reserved.
+
+-- @SINCE-LF 1.13
+
+-- | Test that rounding mode order matches the order in GHC.Types
+module RoundingModeOrder where
+
+import DA.Assert ((===))
+import qualified DA.List
+import qualified DA.List.BuiltinOrder
+
+roundingModes =
+    [ RoundingUp
+    , RoundingDown
+    , RoundingCeiling
+    , RoundingFloor
+    , RoundingHalfUp
+    , RoundingHalfDown
+    , RoundingHalfEven
+    , RoundingUnnecessary
+    ]
+
+test1 = scenario do
+    roundingModes === DA.List.sort roundingModes
+
+test2 = scenario do
+    roundingModes === DA.List.BuiltinOrder.sort roundingModes

daml-lf/spec/daml-lf-1.rst

@@ -3807,13 +3807,17 @@ BigNumeric functions
   the given scale, the result is rounded accordingly the
   ``roundingMode`` as follows:
 
+  - ``'ROUNDING_UP'`` : Round away from zero
+
+  - ``'ROUNDING_DOWN'`` : Rounds towards zero
+
   - ``'ROUNDING_CEILING'`` : Rounds towards positive infinity.
 
   - ``'ROUNDING_FLOOR'`` : Rounds towards negative infinity
 
-  - ``'ROUNDING_DOWN'`` : Rounds towards towards zero
-
-  - ``'ROUNDING_UP'`` : Round towards away from zero
+  - ``'ROUNDING_HALF_UP'`` : Round towards the nearest neighbor unless
+    both neighbors are equidistant, in which case round away from
+    zero.
 
   - ``'ROUNDING_HALF_DOWN'`` : Round towards the nearest neighbor
     unless both neighbors are equidistant, in which case round towards
@@ -3823,10 +3827,6 @@ BigNumeric functions
     unless both neighbors are equidistant, in which case round towards
     the even neighbor.
 
-  - ``'ROUNDING_HALF_UP'`` : Round towards the nearest neighbor unless
-    both neighbors are equidistant, in which case round away from
-    zero.
-
   - ``'ROUNDING_UNNECESSARY'`` : Throw `ArithmeticError` if the exact result cannot be
     represented.