From 9e38929a8794c1f4bc2d597ea4a8f8db17e12a66 Mon Sep 17 00:00:00 2001
From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Mon, 23 Mar 2020 16:54:21 +0100
Subject: [PATCH] `funSubst` works for all applications

Before, `funSubst`, the heart of our type-family resolution
engine, could only deal with `a -> b` and `F a b` on both the
matching side and argument side. Now it works on all applications,
including things of the form `f a`.

Fixes #1242
---
 changelog/2020-03-24T13:08:40+01:00_fix1242 |  1 +
 clash-lib/src/Clash/Core/Type.hs            | 20 ++++++---
 tests/shouldwork/Basic/T1242.hs             | 50 +++++++++++++++++++++
 testsuite/Main.hs                           |  1 +
 4 files changed, 65 insertions(+), 7 deletions(-)
 create mode 100644 changelog/2020-03-24T13:08:40+01:00_fix1242
 create mode 100644 tests/shouldwork/Basic/T1242.hs

diff --git a/changelog/2020-03-24T13:08:40+01:00_fix1242 b/changelog/2020-03-24T13:08:40+01:00_fix1242
new file mode 100644
index 0000000000..943ec90b0b
--- /dev/null
+++ b/changelog/2020-03-24T13:08:40+01:00_fix1242
@@ -0,0 +1 @@
+FIXED: [#1242](https://github.com/clash-lang/clash-compiler/issues/1242) Synthesizing BitPack instances for type with phantom parameter fails
diff --git a/clash-lib/src/Clash/Core/Type.hs b/clash-lib/src/Clash/Core/Type.hs
index f18b50082b..cc3dd16312 100644
--- a/clash-lib/src/Clash/Core/Type.hs
+++ b/clash-lib/src/Clash/Core/Type.hs
@@ -453,10 +453,8 @@ funSubst tcm (Just s) = uncurry go
       Just ty' | ty' `aeqType` ty -> Just s
       _ -> Nothing
     go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families]
-    go ty1@(LitTy _) ty2 = if ty1 `aeqType` ty2 then Just s else Nothing
-    go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys')
-      | tc == tc'
-      = foldl' (funSubst tcm) (Just s) (zip argTys argTys')
+    -- [Note] funSubst FunTy
+    --
     -- Whenever type classes have associated types whose instances 'map' to
     -- functions, we try to find substitutions in the LHS and RHS of these
     -- (type-level) functions. Because we use @funSubst@ recursively, we
@@ -473,9 +471,17 @@ funSubst tcm (Just s) = uncurry go
     -- matching against `Char -> Char` we'd find a duplicate `a -> Char`. We
     -- can't think of any (type-checking) cases where these mappings would map
     -- to different types, so this is OK for our purposes.
-    go (tyView -> FunTy a b) (tyView -> FunTy a' b') =
-      (++) <$> funSubst tcm (Just s) (a, a')
-           <*> funSubst tcm (Just s) (b, b')
+    go (AppTy a1 r1) (AppTy a2 r2) = do
+      s1 <- funSubst tcm (Just s) (a1, a2)
+      funSubst tcm (Just s1) (r1, r2)
+
+    go ty1@(ConstTy _) ty2 =
+      -- Looks through AnnType
+      if ty1 `aeqType` ty2 then Just s else Nothing
+
+    go ty1@(LitTy _) ty2 =
+      -- Looks through AnnType
+      if ty1 `aeqType` ty2 then Just s else Nothing
 
     go _ _ = Nothing
 
diff --git a/tests/shouldwork/Basic/T1242.hs b/tests/shouldwork/Basic/T1242.hs
new file mode 100644
index 0000000000..75b916376a
--- /dev/null
+++ b/tests/shouldwork/Basic/T1242.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module T1242 where
+
+import           Clash.Prelude
+import           Control.DeepSeq   (NFData)
+import           GHC.Generics      (Generic)
+
+data RepKind = AppRep | WireRep
+  deriving (Generic, Show, Eq, NFData, NFDataX)
+
+newtype U16 (t :: RepKind) = U16 (Unsigned 16)
+
+deriving instance Generic (U16 a)
+deriving instance Eq (U16 a)
+deriving instance Show (U16 a)
+deriving instance NFData (U16 a)
+deriving instance NFDataX (U16 a)
+deriving instance BitPack (U16 'AppRep)
+
+class WireApp w a where
+    toWire :: a -> w
+    toApp :: w -> a
+
+instance WireApp (U16 'WireRep) (U16 'AppRep) where
+    toWire v = case v of U16 x -> U16 x
+    toApp v = case v of U16 x -> U16 x
+
+instance (BitPack (t 'AppRep), WireApp (t 'WireRep)  (t 'AppRep)) => BitPack (t 'WireRep) where
+  type BitSize (t 'WireRep) = BitSize (t 'AppRep)
+  pack x = bv
+    where
+        bv :: BitVector (BitSize (t 'WireRep))
+        bv = pack app
+        app :: t 'AppRep
+        app = toApp $ x
+  unpack x = toWire app
+    where
+        app :: t 'AppRep
+        app = unpack x
+
+data Record
+  = Record
+  { f1 :: U16 'WireRep
+  , f2 :: U16 'WireRep
+  } deriving (Generic, NFData, Show, Eq, BitPack, NFDataX)
+
+topEntity :: Signal System Bool -> Signal System Bool
+topEntity _ = pure (unpack 0 == Record (U16 0) (U16 0))
diff --git a/testsuite/Main.hs b/testsuite/Main.hs
index 5c1bd72e97..5fa708e65e 100755
--- a/testsuite/Main.hs
+++ b/testsuite/Main.hs
@@ -266,6 +266,7 @@ runClashTest = defaultMain $ clashTestRoot
           , topEntities=TopEntities ["top1"]
           }
         , runTest "T1012" def{hdlSim=False}
+        , runTest "T1242" def{hdlSim=False}
         , runTest "TagToEnum" def{hdlSim=False}
         , runTest "TestIndex" def{hdlSim=False}
         , runTest "Time" def