From 65aa1fd8891fe70204e53e889c9a9595884c4fce Mon Sep 17 00:00:00 2001
From: associahedron <231829+associahedron@users.noreply.github.com>
Date: Thu, 6 Feb 2020 15:03:29 +0000
Subject: [PATCH] Start dealing with TyConAppCo coercions for
 GeneralizedNewtypeDeriving. (#4428)

* Add tyconappco coerceion test

* Start dealing with TyConAppCo coercions

changelog_begin
changelog_end
---
 .../src/DA/Daml/LFConversion.hs               | 39 ++++++++++++++++++-
 .../daml-test-files/TyConAppCoercion.daml     | 16 ++++++++
 2 files changed, 54 insertions(+), 1 deletion(-)
 create mode 100644 compiler/damlc/tests/daml-test-files/TyConAppCoercion.daml

diff --git a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
index e18edcd60c..4a2c00fcbb 100644
--- a/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
+++ b/compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
@@ -1323,8 +1323,44 @@ convertCoercion env co = evalStateT (go env co) 0
         | Just (tCon, ts, field, flv) <- isSatNewTyCon t s = swap <$> newtypeCoercion tCon ts field flv
         | SymCo co' <- co = swap <$> go env co'
         | SubCo co' <- co = go env co'
+        | Just (tycon, cos) <- splitTyConAppCo_maybe co = do
+            s' <- lift $ convertType env s
+            t' <- lift $ convertType env t
+            case (s', t', cos) of
+                (TOptional a, TOptional b, [co1]) -> do
+                    (f,g) <- go env co1
+                    f' <- mkOptionalFMap a b f
+                    g' <- mkOptionalFMap b a g
+                    pure (f',g')
+                (TList a, TList b, [co1]) -> do
+                    (f,g) <- go env co1
+                    f' <- mkListFMap a b f
+                    g' <- mkListFMap b a g
+                    pure (f',g')
+                _ -> lift $ unhandled "TyConAppCo Coercion" (tycon, cos)
+
         | otherwise = lift $ unhandled "Coercion" co
 
+    mkOptionalFMap :: LF.Type -> LF.Type -> (LF.Expr -> LF.Expr) -> StateT Int ConvertM (LF.Expr -> LF.Expr)
+    mkOptionalFMap _a b f = do
+        y <- mkLamBinder
+        pure $ \x ->
+            ECase x
+                [ CaseAlternative CPNone (ENone b)
+                , CaseAlternative (CPSome y) (ESome b (f (EVar y)))
+                ]
+
+    mkListFMap :: LF.Type -> LF.Type -> (LF.Expr -> LF.Expr) -> StateT Int ConvertM (LF.Expr -> LF.Expr)
+    mkListFMap a b f = do
+        h <- mkLamBinder
+        t <- mkLamBinder
+        pure $ \x -> EBuiltin BEFoldr
+            `ETyApp` a
+            `ETyApp` TList b
+            `ETmApp` (ETmLam (h, a) $ ETmLam (t, TList b) $ ECons b (f (EVar h)) (EVar t))
+            `ETmApp` ENil b
+            `ETmApp` x
+
     newtypeCoercion tCon ts field flv = do
         ts' <- lift $ mapM (convertType env) ts
         t' <- lift $ convertQualifiedTyCon env tCon
@@ -1491,7 +1527,8 @@ convertType env = go env
             fieldTys <- mapM (go env) ts
             let fieldNames = map mkSuperClassField [1..]
             pure $ TStruct (zip fieldNames fieldTys)
-         | tyConFlavour t == ClassFlavour && envLfVersion env `supports` featureTypeSynonyms = do
+        | tyConFlavour t == ClassFlavour
+        , envLfVersion env `supports` featureTypeSynonyms = do
            tySyn <- convertQualifiedTySyn env t
            TSynApp tySyn <$> mapM (go env) ts
         | otherwise =
diff --git a/compiler/damlc/tests/daml-test-files/TyConAppCoercion.daml b/compiler/damlc/tests/daml-test-files/TyConAppCoercion.daml
new file mode 100644
index 0000000000..94a9f0c8c7
--- /dev/null
+++ b/compiler/damlc/tests/daml-test-files/TyConAppCoercion.daml
@@ -0,0 +1,16 @@
+daml 1.2
+module TyConAppCoercion () where
+
+class MyClass a where
+  f1 : Optional a -> a
+  f1 = error ""
+
+  f2 : [a] -> a
+  f2 = error ""
+
+data X = X
+
+instance MyClass X where
+
+newtype Y = Y X
+  deriving MyClass