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

@@ -0,0 +1 @@
+FIXED: [#1242](https://github.com/clash-lang/clash-compiler/issues/1242) Synthesizing BitPack instances for type with phantom parameter fails

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
 

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))

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