From b0c8e5c981c0abb6cab2039597c02472f5fa33d2 Mon Sep 17 00:00:00 2001
From: Martijn Bastiaan <martijn@qbaylogic.com>
Date: Sun, 21 Jul 2024 09:44:57 +0200
Subject: [PATCH] Add GHC 9.8 support

---
 .github/workflows/ci.yml |  1 +
 .vscode/settings.json    |  6 ++++++
 cabal.project            | 15 ++++++++++-----
 circuit-notation.cabal   |  2 +-
 src/CircuitNotation.hs   | 25 +++++++++++++++----------
 5 files changed, 33 insertions(+), 16 deletions(-)
 create mode 100644 .vscode/settings.json

diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index a8c24e3..daba217 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -40,6 +40,7 @@ jobs:
           - "9.2.8"
           - "9.4.8"
           - "9.6.4"
+          - "9.8.2"
 
     steps:
     - uses: actions/checkout@v3
diff --git a/.vscode/settings.json b/.vscode/settings.json
new file mode 100644
index 0000000..3c26485
--- /dev/null
+++ b/.vscode/settings.json
@@ -0,0 +1,6 @@
+{
+  "files.insertFinalNewline": true,
+  "files.trimFinalNewlines": true,
+  "files.trimTrailingWhitespace": true,
+  "editor.tabSize": 2
+}
diff --git a/cabal.project b/cabal.project
index 6d8696a..494ad32 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,7 +1,12 @@
 packages: .
 
-source-repository-package
-    type: git
-    location: https://github.com/clash-lang/clash-compiler.git
-    tag: 5b055fb3fcdaf6e2b89cb86486d7280fc781fa84
-    subdir: clash-prelude
\ No newline at end of file
+if(impl(ghc >= 9.0))
+    source-repository-package
+        type: git
+        location: https://github.com/clash-lang/clash-compiler.git
+        tag: c300105837fced0207963b172845186c3ae8d5f8
+        subdir: clash-prelude
+
+if(impl(ghc >= 9.10))
+    allow-newer:
+        string-interpolate:template-haskell,
diff --git a/circuit-notation.cabal b/circuit-notation.cabal
index ec6ae68..4bf3a88 100644
--- a/circuit-notation.cabal
+++ b/circuit-notation.cabal
@@ -28,7 +28,7 @@ library
     , clash-prelude >= 1.0
     , containers
     , data-default
-    , ghc (>=8.6 && <8.8) || (>=8.10 && < 9.8)
+    , ghc (>=8.6 && <8.8) || (>=8.10 && < 9.10)
     , lens
     , mtl
     , parsec
diff --git a/src/CircuitNotation.hs b/src/CircuitNotation.hs
index 67bde1f..959d103 100644
--- a/src/CircuitNotation.hs
+++ b/src/CircuitNotation.hs
@@ -133,7 +133,9 @@ import "ghc" GHC.Types.Unique.Map
 import GHC.Types.Unique.Map
 #endif
 
+#if __GLASGOW_HASKELL__ <= 900
 import GHC.Types.Unique.Map.Extra
+#endif
 
 -- clash-prelude
 import Clash.Prelude (Vec((:>), Nil))
@@ -486,7 +488,7 @@ tupT tys = noLoc $ HsTupleTy noExt hsBoxedTuple tys
 
 vecT :: SrcSpanAnnA -> [LHsType GhcPs] -> LHsType GhcPs
 vecT s [] = L s $ HsParTy noExt (conT s (thName ''Vec) `appTy` tyNum s 0 `appTy` (varT s (genLocName s "vec")))
-vecT s tys = L s $ HsParTy noExt (conT s (thName ''Vec) `appTy` tyNum s (length tys) `appTy` head tys)
+vecT s tys@(ty:_) = L s $ HsParTy noExt (conT s (thName ''Vec) `appTy` tyNum s (length tys) `appTy` ty)
 
 tyNum :: SrcSpanAnnA -> Int -> LHsType GhcPs
 tyNum s i = L s (HsTyLit noExtField (HsNumTy GHC.NoSourceText (fromIntegral i)))
@@ -618,8 +620,10 @@ lamE pats expr = noLoc $ HsLam noExtField mg
     mg :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 #if __GLASGOW_HASKELL__ < 906
     mg = MG noExtField matches GHC.Generated
-#else
+#elif __GLASGOW_HASKELL__ < 908
     mg = MG GHC.Generated matches
+#else
+    mg = MG (GHC.Generated GHC.DoPmc) matches
 #endif
 
     matches :: GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
@@ -874,18 +878,19 @@ checkCircuit = do
       topNames = portNames Slave slaves <> portNames Master masters
       nameMap = listToUniqMap_C mappend $ topNames <> concatMap bindingNames binds
 
-  duplicateMasters <- concat <$> forM (nonDetUniqMapToList nameMap) \(name, occ) ->
+  duplicateMasters <- concat <$> forM (nonDetUniqMapToList nameMap) \(name, occ) -> do
+    let isIgnored = case unpackFS name of {('_':_) -> True; _ -> False}
+
     case occ of
+      ([], []) -> pure []
       ([_], [_]) -> pure []
-      (ss, ms) -> do
-        unless (head (unpackFS name) == '_') $ do
-          when (null ms) $ errM (locA (head ss)) $ "Slave port " <> show name <> " has no associated master"
-          when (null ss) $ errM (locA (head ms)) $ "Master port " <> show name <> " has no associated slave"
+      (s:_, []) | not isIgnored -> errM (locA s) ("Slave port " <> show name <> " has no associated master") >> pure []
+      ([], m:_) | not isIgnored -> errM (locA m) ("Master port " <> show name <> " has no associated slave") >> pure []
+      (ss@(s:_:_), _) ->
         -- would be nice to show locations of all occurrences here, not sure how to do that while
         -- keeping ghc api
-        when (length ss > 1) $
-          errM (locA (head ss)) $ "Slave port " <> show name <> " defined " <> show (length ss) <> " times"
-
+        errM (locA s) ("Slave port " <> show name <> " defined " <> show (length ss) <> " times") >> pure []
+      (_ss, ms) -> do
         -- if master is defined multiple times, we broadcast it
         if length ms > 1
           then pure [name]