Convert type classes to LF type synonyms (digital-asset#4023)

changelog_begin changelog_end
axman6 · Jan 24, 2020 · 3496ce0 · 3496ce0
1 parent 93d7b1a
commit 3496ce0
Show file tree

Hide file tree

Showing 7 changed files with 128 additions and 47 deletions.
diff --git a/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Version.hs b/compiler/daml-lf-ast/src/DA/Daml/LF/Ast/Version.hs
@@ -88,6 +88,13 @@ featureGenMap = Feature
     , featureCppFlag = "DAML_GENMAP"
     }
 
+featureTypeSynonyms :: Feature
+featureTypeSynonyms = Feature
+    { featureName = "LF type synonyms"
+    , featureMinVersion = versionDev
+    , featureCppFlag = "DAML_TYPE_SYNONYMS"
+    }
+
 -- Unstable, experimental features. This should stay in 1.dev forever.
 -- Features implemented with this flag should be moved to a separate
 -- feature flag once the decision to add them permanently has been made.

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -432,7 +432,11 @@ convertTypeDef env o@(ATyCon t) = withRange (convNameLoc t) $ if
     | isEnumTyCon t
     -> convertEnumDef env t
 
-    -- Simple record types. This includes newtypes, typeclasses, and
+    -- Type classes
+    | isClassTyCon t
+    -> convertClassDef env t
+
+    -- Simple record types. This includes newtypes, and
     -- single constructor algebraic types with no fields or with
     -- labelled fields.
     | isSimpleRecordTyCon t
@@ -459,21 +463,41 @@ convertSimpleRecordDef :: Env -> TyCon -> ConvertM [Definition]
 convertSimpleRecordDef env tycon = do
     let con = tyConSingleDataCon tycon
         flavour = tyConFlavour tycon
-        sanitize -- DICTIONARY SANITIZATION step (1)
-            | flavour == ClassFlavour = (TUnit :->)
-            | otherwise = id
         labels = ctorLabels con
         (_, theta, args, _) = dataConSig con
 
     (env', tyVars) <- bindTypeVars env (tyConTyVars tycon)
     fieldTypes <- mapM (convertType env') (theta ++ args)
 
-    let fields = zipExact labels (map sanitize fieldTypes)
+    let fields = zipExact labels fieldTypes
         tconName = mkTypeCon [getOccText tycon]
         typeDef = defDataType tconName tyVars (DataRecord fields)
         workerDef = defNewtypeWorker (envLFModuleName env) tycon tconName con tyVars fields
+
     pure $ typeDef : [workerDef | flavour == NewtypeFlavour]
 
+convertClassDef :: Env -> TyCon -> ConvertM [Definition]
+convertClassDef env tycon = do
+    let con = tyConSingleDataCon tycon
+        sanitize = (TUnit :->) -- DICTIONARY SANITIZATION step (1)
+        labels = ctorLabels con
+        (_, theta, args, _) = dataConSig con
+
+    (env', tyVars) <- bindTypeVars env (tyConTyVars tycon)
+    fieldTypes <- mapM (convertType env') (theta ++ args)
+
+    let fields = zipExact labels (map sanitize fieldTypes)
+        tconName = mkTypeCon [getOccText tycon]
+        tsynName = mkTypeSyn [getOccText tycon]
+        typeDef
+            | envLfVersion env `supports` featureTypeSynonyms =
+              -- Structs must have > 0 fields, therefore we simply make a typeclass a synonym for Unit
+              -- if it has no fields
+              defTypeSyn tsynName tyVars (if null fields then TUnit else TStruct fields)
+            | otherwise = defDataType tconName tyVars (DataRecord fields)
+
+    pure [typeDef]
+
 defNewtypeWorker :: NamedThing a => LF.ModuleName -> a -> TypeConName -> DataCon
     -> [(TypeVarName, LF.Kind)] -> [(FieldName, LF.Type)] -> Definition
 defNewtypeWorker lfModuleName loc tconName con tyVars fields =
@@ -657,7 +681,10 @@ convertBind env (name, x)
           -- NOTE (drsk): We only want to do the sanitization for non-newtypes. The sanitization
           -- step 3 for newtypes is done in the convertCoercion function.
           DFunId False ->
-            over (_ETyLams . _2 . _ETmLams . _2 . _ERecCon . _2 . each . _2) (ETmLam (mkVar "_", TUnit))
+              let fieldsPrism
+                    | envLfVersion env `supports` featureTypeSynonyms = _EStructCon
+                    | otherwise = _ERecCon . _2
+              in over (_ETyLams . _2 . _ETmLams . _2 . fieldsPrism . each . _2) (ETmLam (mkVar "_", TUnit))
           _ -> id
     name' <- convValWithType env name
     pure [defValue name name' (sanitize x')]
@@ -775,7 +802,7 @@ convertExpr env0 e = do
     -- conversion of bodies of $con2tag functions
     go env (VarIn GHC_Base "getTag") (LType (TypeCon t _) : LExpr x : args) = fmap (, args) $ do
         x' <- convertExpr env x
-        t' <- convertQualified env t
+        t' <- convertQualifiedTyCon env t
         let mkCasePattern con
                 -- Note that tagToEnum# can also be used on non-enum types, i.e.,
                 -- types where not all constructors are nullary.
@@ -944,7 +971,7 @@ convertExpr env0 e = do
             let fldIndex = fromJust (elemIndex x vs)
             let fldName = fldNames !! fldIndex
             recTyp <- convertType env (varType bind)
-            pure $ ERecProj (fromTCon recTyp) fldName scrutinee' `ETmApp` EUnit
+            pure $ mkDictProj env (fromTCon recTyp) fldName scrutinee' `ETmApp` EUnit
     go env o@(Case scrutinee bind _ [alt@(DataAlt con, vs, x)]) args = fmap (, args) $ do
         convertType env (varType bind) >>= \case
             TText -> asLet
@@ -957,7 +984,7 @@ convertExpr env0 e = do
             TUpdate{} -> asLet
             TScenario{} -> asLet
             TAny{} -> asLet
-            tcon | isSimpleRecordCon con -> do
+            tcon | isSimpleRecordCon con || isClassCon con -> do
                 let fields = ctorLabels con
                 case zipExactMay vs fields of
                     Nothing -> unsupported "Pattern match with existential type" alt
@@ -1035,12 +1062,16 @@ isEnumCon = isEnumTyCon . dataConTyCon
 isConstraintTupleCon :: DataCon -> Bool
 isConstraintTupleCon = isConstraintTupleTyCon . dataConTyCon
 
+isClassCon :: DataCon -> Bool
+isClassCon = isClassTyCon . dataConTyCon
+
 isSimpleRecordCon :: DataCon -> Bool
 isSimpleRecordCon con =
     (conHasLabels con || conHasNoArgs con)
     && conIsSingle con
     && not (isEnumCon con)
     && not (isConstraintTupleCon con)
+    && not (isClassCon con)
 
 isVariantRecordCon :: DataCon -> Bool
 isVariantRecordCon con = conHasLabels con && not (conIsSingle con)
@@ -1049,6 +1080,7 @@ isVariantRecordCon con = conHasLabels con && not (conIsSingle con)
 data DataConClass
     = EnumCon -- ^ constructor for an enum type
     | SimpleRecordCon -- ^ constructor for a record type
+    | ClassCon -- ^ constructor for a type class
     | SimpleVariantCon -- ^ constructor for a variant type with no synthetic record type
     | VariantRecordCon -- ^ constructor for a variant type with a synthetic record type
     | ConstraintTupleCon -- ^ constructor for a constraint tuple
@@ -1058,6 +1090,7 @@ classifyDataCon :: DataCon -> DataConClass
 classifyDataCon con
     | isEnumCon con = EnumCon
     | isConstraintTupleCon con = ConstraintTupleCon
+    | isClassCon con = ClassCon
     | isSimpleRecordCon con = SimpleRecordCon
     | isVariantRecordCon con = VariantRecordCon
     | otherwise = SimpleVariantCon
@@ -1108,8 +1141,9 @@ convertDataCon env m con args
                     [tmArg] -> pure tmArg
                     _ -> unhandled "constructor with more than two unnamed arguments" xargs
 
-            SimpleRecordCon ->
-                pure $ ERecCon tcon (zipExact fldNames tmArgs)
+            ClassCon -> pure $ mkDictCon env tcon (zipExact fldNames tmArgs)
+
+            SimpleRecordCon -> pure $ ERecCon tcon (zipExact fldNames tmArgs)
 
             VariantRecordCon -> do
                 let recTCon = fmap (synthesizeVariantRecord ctorName) qTCon
@@ -1225,6 +1259,20 @@ mkProjBindings env recExpr recTyp vsFlds e =
     , not (isDeadOcc (occInfo (idInfo v)))
     ]
 
+mkDictCon :: Env -> TypeConApp -> [(LF.FieldName, LF.Expr)] -> LF.Expr
+mkDictCon env tcon fields
+-- Structs must have > 0 fields, therefore we simply make a typeclass a synonym for Unit
+-- if it has no fields.
+    | envLfVersion env `supports` featureTypeSynonyms && null fields = EUnit
+    | envLfVersion env `supports` featureTypeSynonyms = EStructCon fields
+    | otherwise = ERecCon tcon fields
+
+mkDictProj :: Env -> TypeConApp -> LF.FieldName -> LF.Expr -> LF.Expr
+mkDictProj env tcon =
+    if envLfVersion env `supports` featureTypeSynonyms
+      then EStructProj
+      else ERecProj tcon
+
 -- Convert a coercion @S ~ T@ to a pair of lambdas
 -- @(to :: S -> T, from :: T -> S)@ in higher-order abstract syntax style.
 --
@@ -1279,19 +1327,20 @@ convertCoercion env co = evalStateT (go env co) 0
 
     newtypeCoercion tCon ts field flv = do
         ts' <- lift $ mapM (convertType env) ts
-        t' <- lift $ convertQualified env tCon
+        t' <- lift $ convertQualifiedTyCon env tCon
         let tcon = TypeConApp t' ts'
-        let sanitizeTo x
-                -- NOTE(MH): This is DICTIONARY SANITIZATION step (3).
-                | flv == ClassFlavour = ETmLam (mkVar "_", TUnit) x
-                | otherwise = x
-            sanitizeFrom x
-                -- NOTE(MH): This is DICTIONARY SANITIZATION step (2).
-                | flv == ClassFlavour = x `ETmApp` EUnit
-                | otherwise = x
-        let to expr = ERecCon tcon [(field, sanitizeTo expr)]
-        let from expr = sanitizeFrom $ ERecProj tcon field expr
-        pure (to, from)
+        pure $ if flv == ClassFlavour
+           then (\expr -> mkDictCon env tcon [(field, sanitizeTo expr)], sanitizeFrom . mkDictProj env tcon field)
+           else (\expr -> ERecCon tcon [(field, expr)], ERecProj tcon field)
+      where
+          sanitizeTo x
+              -- NOTE(MH): This is DICTIONARY SANITIZATION step (3).
+              | flv == ClassFlavour = ETmLam (mkVar "_", TUnit) x
+              | otherwise = x
+          sanitizeFrom x
+              -- NOTE(MH): This is DICTIONARY SANITIZATION step (2).
+              | flv == ClassFlavour = x `ETmApp` EUnit
+              | otherwise = x
 
     mkLamBinder = do
         n <- state (dupe . succ)
@@ -1335,14 +1384,20 @@ rewriteStableQualified env q@(Qualified pkgRef modName obj) =
       Nothing -> q
       Just pkgId -> Qualified (PRImport pkgId) modName obj
 
-convertQualified :: NamedThing a => Env -> a -> ConvertM (Qualified TypeConName)
-convertQualified env x = do
+convertQualified :: NamedThing a => (T.Text -> t) -> Env -> a -> ConvertM (Qualified t)
+convertQualified toT env x = do
   pkgRef <- nameToPkgRef env x
   let modName = convertModuleName $ GHC.moduleName $ nameModule $ getName x
   pure $ rewriteStableQualified env $ Qualified
     pkgRef
     modName
-    (mkTypeCon [getOccText x])
+    (toT $ getOccText x)
+
+convertQualifiedTySyn :: NamedThing a => Env -> a -> ConvertM (Qualified TypeSynName)
+convertQualifiedTySyn = convertQualified (\t -> mkTypeSyn [t])
+
+convertQualifiedTyCon :: NamedThing a => Env -> a -> ConvertM (Qualified TypeConName)
+convertQualifiedTyCon = convertQualified (\t -> mkTypeCon [t])
 
 nameToPkgRef :: NamedThing a => Env -> a -> ConvertM LF.PackageRef
 nameToPkgRef env x =
@@ -1405,7 +1460,7 @@ convertTyCon env t
     | otherwise = defaultTyCon
     where
         arity = tyConArity t
-        defaultTyCon = TCon <$> convertQualified env t
+        defaultTyCon = TCon <$> convertQualifiedTyCon env t
 
 metadataTys :: UniqSet FastString
 metadataTys = mkUniqSet ["MetaData", "MetaCons", "MetaSel"]
@@ -1436,6 +1491,9 @@ convertType env = go env
             fieldTys <- mapM (go env) ts
             let fieldNames = map mkIndexedField [1..]
             pure $ TStruct (zip fieldNames fieldTys)
+         | tyConFlavour t == ClassFlavour && envLfVersion env `supports` featureTypeSynonyms = do
+           tySyn <- convertQualifiedTySyn env t
+           TSynApp tySyn <$> mapM (go env) ts
         | otherwise =
             mkTApps <$> convertTyCon env t <*> mapM (go env) ts
 
@@ -1501,6 +1559,10 @@ defDataType :: TypeConName -> [(TypeVarName, LF.Kind)] -> DataCons -> Definition
 defDataType name params constrs =
   DDataType $ DefDataType Nothing name (IsSerializable False) params constrs
 
+defTypeSyn :: TypeSynName -> [(TypeVarName, LF.Kind)] -> LF.Type -> Definition
+defTypeSyn name params ty =
+  DTypeSyn $ DefTypeSyn Nothing name params ty
+
 defValue :: NamedThing a => a -> (ExprValName, LF.Type) -> LF.Expr -> Definition
 defValue loc binder@(name, lftype) body =
   DValue $ DefValue (convNameLoc loc) binder (HasNoPartyLiterals True) (IsTest isTest) body

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilLF.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/UtilLF.hs
@@ -52,6 +52,9 @@ mkChoiceName = ChoiceName
 mkTypeCon :: [T.Text] -> TypeConName
 mkTypeCon = TypeConName
 
+mkTypeSyn :: [T.Text] -> TypeSynName
+mkTypeSyn = TypeSynName
+
 mkIdentity :: Type -> Expr
 mkIdentity t = ETmLam (varV1, t) $ EVar varV1
 

diff --git a/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.EXPECTED.md b/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.EXPECTED.md
@@ -14,9 +14,3 @@ not present in the class itself.
 > <a name="function-constrainedclassmethod-bar-13431"></a>[bar](#function-constrainedclassmethod-bar-13431)
 > 
 > > : [Eq](https://docs.daml.com/daml/reference/base.html#class-ghc-classes-eq-21216) t =\> t -\> t
-
-<a name="class-constrainedclassmethod-b-99749"></a>**class** [B](#class-constrainedclassmethod-b-99749) t **where**
-
-> <a name="function-constrainedclassmethod-baz-40143"></a>[baz](#function-constrainedclassmethod-baz-40143)
-> 
-> > : [B](#class-constrainedclassmethod-b-99749) b =\> b -\> t
diff --git a/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.EXPECTED.rst b/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.EXPECTED.rst
@@ -22,12 +22,3 @@ Typeclasses
 
   `bar <function-constrainedclassmethod-bar-13431_>`_
     \: `Eq <https://docs.daml.com/daml/reference/base.html#class-ghc-classes-eq-21216>`_ t \=\> t \-\> t
-
-.. _class-constrainedclassmethod-b-99749:
-
-**class** `B <class-constrainedclassmethod-b-99749_>`_ t **where**
-
-  .. _function-constrainedclassmethod-baz-40143:
-
-  `baz <function-constrainedclassmethod-baz-40143_>`_
-    \: `B <class-constrainedclassmethod-b-99749_>`_ b \=\> b \-\> t
diff --git a/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.daml b/compiler/damlc/tests/daml-test-files/ConstrainedClassMethod.daml
@@ -1,5 +1,4 @@
 {-# LANGUAGE ConstrainedClassMethods #-}
-
 daml 1.2
 -- | This module tests the case where a class method contains a constraint
 -- not present in the class itself.
@@ -9,5 +8,8 @@ class A t where
     foo : t -> t
     bar : Eq t => t -> t
 
-class B t where
-    baz : B b => b -> t
+-- This would create a recursive type synonym.
+-- For now, we do not support this. As a workaround
+-- you can do manual dictionary passing.
+-- class B t where
+--    baz : B b => b -> t
diff --git a/compiler/damlc/tests/src/unstable-types.sh b/compiler/damlc/tests/src/unstable-types.sh
@@ -31,7 +31,28 @@ for LF_VERSION in $PKG_DB/*; do
     if [ $(basename $LF_VERSION) != "1.6" ]; then
         stdlib=$LF_VERSION/daml-stdlib-*.dalf
         prim=$LF_VERSION/daml-prim.dalf
-        $DIFF -b -u <(get_serializable_types $stdlib) <(cat <<EOF
+        # MetaEquiv is a typeclass without methods and is translated to a type synonym for Unit
+        # in newer LF versions.
+        if [ $(basename $LF_VERSION) == "1.dev" ]; then
+            $DIFF -b -u <(get_serializable_types $stdlib) <(cat <<EOF
+"DA.Random:Minstd"
+"DA.Next.Set:Set"
+"DA.Next.Map:Map"
+"DA.Generics:MetaSel0"
+"DA.Generics:MetaData0"
+"DA.Generics:DecidedStrictness"
+"DA.Generics:SourceStrictness"
+"DA.Generics:SourceUnpackedness"
+"DA.Generics:Associativity"
+"DA.Generics:Infix0"
+"DA.Generics:Fixity"
+"DA.Generics:K1"
+"DA.Generics:Par1"
+"DA.Generics:U1"
+EOF
+)
+        else
+            $DIFF -b -u <(get_serializable_types $stdlib) <(cat <<EOF
 "DA.Upgrade:MetaEquiv"
 "DA.Random:Minstd"
 "DA.Next.Set:Set"
@@ -49,7 +70,8 @@ for LF_VERSION in $PKG_DB/*; do
 "DA.Generics:U1"
 EOF
 )
-        $DIFF -b -u <(get_serializable_types $prim) <(cat <<EOF
+        fi
+      $DIFF -b -u <(get_serializable_types $prim) <(cat <<EOF
 EOF
 )
     fi