clash-lib: Print constructor names in netlist errors

clash-lang · Dec 30, 2023 · b917713 · b917713
1 parent 9c91a8b
commit b917713
Showing 1 changed file with 17 additions and 12 deletions.
diff --git a/clash-lib/src/Clash/Netlist.hs b/clash-lib/src/Clash/Netlist.hs
@@ -1027,26 +1027,31 @@ mkDcApplication declType [dstHType] bndr dc args = do
     ([Just argHwTy],[argExpr]) | argHwTy == dstHType ->
       return (HW.DataCon dstHType (DC (Void Nothing,-1)) [argExpr])
     _ -> case dstHType of
-      SP _ dcArgPairs -> do
+      SP nm dcArgPairs -> do
         let dcI      = dcTag dc - 1
             dcArgs   = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI
         case compare (length dcArgs) (length argExprsFiltered) of
           EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprsFiltered)
-          LT -> error $ $(curLoc) ++ "Over-applied constructor"
-          GT -> error $ $(curLoc) ++ "Under-applied constructor"
-      Product _ _ dcArgs ->
+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm
+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm
+      Product nm _ dcArgs ->
         case compare (length dcArgs) (length argExprsFiltered) of
           EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)
-          LT -> error $ $(curLoc) ++ "Over-applied constructor"
-          GT -> error $ $(curLoc) ++ "Under-applied constructor"
-      CustomProduct _ _ _ _ dcArgs ->
+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm
+          GT -> error $ unlines [ $(curLoc) ++ "Under-applied constructor:" ++ StrictText.unpack dcNm
+                                , "dcArgs=" ++ unlines [" - " ++ show x | x <- dcArgs]
+                                , "argExprs=" ++ unlines [" - " ++ show x | x <- argExprs]
+                                , "hWTysFilt=" ++ unlines [" - " ++ show x | x <- hWTysFiltered]
+                                , "argExprsFilt=" ++ unlines [" - " ++ show x | x <- argExprsFiltered]
+                                ]
+      CustomProduct nm _ _ _ dcArgs ->
         case compare (length dcArgs) (length argExprsFiltered) of
           EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)
-          LT -> error $ $(curLoc) ++ "Over-applied constructor"
-          GT -> error $ $(curLoc) ++ "Under-applied constructor"
+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm
+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm
       Sum _ _ ->
         return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) [])
-      CustomSP _ _ _ dcArgsTups -> do
+      CustomSP nm _ _ dcArgsTups -> do
         -- Safely get item from list, or err with note
         let dcI    = dcTag dc - 1
         let note   = $(curLoc) ++ "No DC with tag: " ++ show dcI
@@ -1055,8 +1060,8 @@ mkDcApplication declType [dstHType] bndr dc args = do
 
         case compare (length dcArgs) (length argExprsFiltered) of
           EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprsFiltered)
-          LT -> error $ $(curLoc) ++ "Over-applied constructor"
-          GT -> error $ $(curLoc) ++ "Under-applied constructor"
+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm
+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm
 
       CustomSum _ _ _ _ ->
         return (HW.DataCon dstHType (DC (dstHType, dcTag dc - 1)) [])