Use :>! instead of :> for pattern matching Vecs (#21)

This is used to workaround (spurious) warnings GHC generates on newer
versions. Example of such a warning:

    example/Example.hs:170:1: error: [GHC-62161] [-Wincomplete-uni-patterns, Werror=incomplete-uni-patterns]
        Pattern match(es) are non-exhaustive
        In a pattern binding:
            Patterns of type ‘BusTag (DF dom Int) (Bwd (DF dom Int))
                              :-> BusTag
                                    (Vec 1 (DF dom Int)) (Fwd (Vec 1 (DF dom Int)))’ not matched:
                _ :-> BusTagBundle (Cons _ _)
        |
    170 | fanout = circuit $ \a -> do
        | ^^^^^^^^^^^^^^^^^^^^^^^^^^^...

Author: martijnbastiaan

.github/workflows/ci.yml

@@ -68,8 +68,8 @@ jobs:
     - name: Build
       run: |
         cabal build all --write-ghc-environment-files=always
-        ghc -iexample Example
-        ghc -iexample Testing
+        ghc -Wall -Werror -iexample Example
+        ghc -Wall -Werror -iexample Testing
 
     - name: Test
       run: |

example/Example.hs

@@ -166,6 +166,14 @@ vec0 = circuit \[] -> ()
 vec00 :: Circuit (Vec 0 a) (Vec 0 a)
 vec00 = circuit \[] -> []
 
+fanout :: forall dom. Circuit (DF dom Int) (DF dom Int)
+fanout = circuit $ \a -> do
+  [x] <- go -< a
+  idC -< x
+ where
+  go :: Circuit (DF dom Int) (Vec n (DF dom Int))
+  go = error "Not implemented"
+
 -- test that signals can be duplicated
 dupSignalC0 :: Circuit (Signal dom Bool) (Signal dom Bool, Signal dom Bool)
 dupSignalC0 = circuit $ \x -> (x, x)

src/Circuit.hs

@@ -10,6 +10,7 @@
 This file contains the 'Circuit' type, that the notation describes.
 -}
 
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveFunctor          #-}
 {-# LANGUAGE GADTs                  #-}
@@ -27,6 +28,16 @@ module Circuit where
 
 import           Clash.Prelude
 
+#if __GLASGOW_HASKELL__ > 900
+-- | Unsafe version of ':>'. Will fail if applied to empty vectors. This is used to
+-- workaround spurious incomplete pattern match warnings generated in newer GHC
+-- versions.
+pattern (:>!) :: a -> Vec n a -> Vec (n + 1) a
+pattern (:>!) x xs <- (\ys -> (head ys, tail ys) -> (x,xs))
+{-# COMPLETE (:>!) #-}
+infixr 5 :>!
+#endif
+
 type family Fwd a
 type family Bwd a
 

src/CircuitNotation.hs

@@ -443,7 +443,7 @@ tupP :: p ~ GhcPs => [LPat p] -> LPat p
 tupP [pat] = pat
 tupP pats = noLoc $ TuplePat noExt pats GHC.Boxed
 
-vecP :: SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
+vecP :: (?nms :: ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
 vecP srcLoc = \case
   [] -> go []
 #if __GLASGOW_HASKELL__ < 904
@@ -464,7 +464,7 @@ vecP srcLoc = \case
       l1 = l0
 #endif
     in
-      L srcLoc $ conPatIn (L l1 (thName '(:>))) (InfixCon p (go pats))
+      L srcLoc $ conPatIn (L l1 (consPat ?nms)) (InfixCon p (go pats))
   go [] = L srcLoc $ WildPat noExtField
 
 varP :: SrcSpanAnnA -> String -> LPat GhcPs
@@ -1316,6 +1316,7 @@ data ExternalNames = ExternalNames
   , fwdBwdCon :: GHC.RdrName
   , fwdAndBwdTypes :: Direction -> GHC.RdrName
   , trivialBwd :: GHC.RdrName
+  , consPat :: GHC.RdrName
   }
 
 defExternalNames :: ExternalNames
@@ -1330,4 +1331,9 @@ defExternalNames = ExternalNames
       Fwd -> GHC.Unqual (OccName.mkTcOcc "Fwd")
       Bwd -> GHC.Unqual (OccName.mkTcOcc "Bwd")
   , trivialBwd = GHC.Unqual (OccName.mkVarOcc "unitBwd")
+#if __GLASGOW_HASKELL__ > 900
+  , consPat = GHC.Unqual (OccName.mkDataOcc ":>!")
+#else
+  , consPat = GHC.Unqual (OccName.mkDataOcc ":>")
+#endif
   }