From 9d09ede7b90b82adf60b5a26e230d032e2508b6e Mon Sep 17 00:00:00 2001
From: Mikolaj Konarski <mikolaj.konarski@gmail.com>
Date: Mon, 4 Dec 2023 12:11:45 +0100
Subject: [PATCH] Fix the too lenient inferred phantom role annotations

---
 Data/Array/Internal.hs          | 2 ++
 Data/Array/Internal/Dynamic.hs  | 2 ++
 Data/Array/Internal/DynamicG.hs | 2 ++
 Data/Array/Internal/DynamicS.hs | 2 ++
 Data/Array/Internal/DynamicU.hs | 2 ++
 Data/Array/Internal/Ranked.hs   | 2 ++
 Data/Array/Internal/RankedG.hs  | 2 ++
 Data/Array/Internal/RankedS.hs  | 2 ++
 Data/Array/Internal/RankedU.hs  | 2 ++
 Data/Array/Internal/Shaped.hs   | 2 ++
 Data/Array/Internal/ShapedG.hs  | 2 ++
 Data/Array/Internal/ShapedS.hs  | 2 ++
 Data/Array/Internal/ShapedU.hs  | 2 ++
 orthotope.cabal                 | 2 ++
 14 files changed, 28 insertions(+)

diff --git a/Data/Array/Internal.hs b/Data/Array/Internal.hs
index 5fe329c..4659836 100644
--- a/Data/Array/Internal.hs
+++ b/Data/Array/Internal.hs
@@ -21,6 +21,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -124,6 +125,7 @@ prettyShowL l = render . pPrintPrec l 0
 -- dimension starts you calculate vector index @offset + i*strides[0]@.
 -- To find where item /i,j/ of the two outermost dimensions is you
 -- calculate vector index @offset + i*strides[0] + j*strides[1]@, etc.
+type role T representational nominal
 data T v a = T
     { strides :: ![Int]   -- length is tensor rank
     , offset  :: !Int     -- offset into vector of values
diff --git a/Data/Array/Internal/Dynamic.hs b/Data/Array/Internal/Dynamic.hs
index 6fd7961..f53e26f 100644
--- a/Data/Array/Internal/Dynamic.hs
+++ b/Data/Array/Internal/Dynamic.hs
@@ -19,6 +19,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Data.Array.Internal.Dynamic(
@@ -103,6 +104,7 @@ instance Vector V.Vector where
   {-# INLINE vAny #-}
   vAny = V.any
 
+type role Array nominal
 newtype Array a = A { unA :: G.Array V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/DynamicG.hs b/Data/Array/Internal/DynamicG.hs
index f35f610..b5824f1 100644
--- a/Data/Array/Internal/DynamicG.hs
+++ b/Data/Array/Internal/DynamicG.hs
@@ -17,6 +17,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- | Arrays of dynamic size.  The arrays are polymorphic in the underlying
@@ -54,6 +55,7 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>))
 import Data.Array.Internal
 
 -- | Arrays stored in a /v/ with values of type /a/.
+type role Array representational nominal
 data Array v a = A !ShapeL !(T v a)
   deriving (Generic, Data)
 
diff --git a/Data/Array/Internal/DynamicS.hs b/Data/Array/Internal/DynamicS.hs
index b744282..c744d2c 100644
--- a/Data/Array/Internal/DynamicS.hs
+++ b/Data/Array/Internal/DynamicS.hs
@@ -20,6 +20,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -110,6 +111,7 @@ instance Vector V.Vector where
   {-# INLINE vAny #-}
   vAny = V.any
 
+type role Array nominal
 newtype Array a = A { unA :: G.Array V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/DynamicU.hs b/Data/Array/Internal/DynamicU.hs
index c76788c..23435f3 100644
--- a/Data/Array/Internal/DynamicU.hs
+++ b/Data/Array/Internal/DynamicU.hs
@@ -20,6 +20,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Data.Array.Internal.DynamicU(
@@ -107,6 +108,7 @@ instance Vector V.Vector where
   {-# INLINE vAny #-}
   vAny = V.any
 
+type role Array nominal
 newtype Array a = A { unA :: G.Array V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/Ranked.hs b/Data/Array/Internal/Ranked.hs
index 308d0c8..4b94f55 100644
--- a/Data/Array/Internal/Ranked.hs
+++ b/Data/Array/Internal/Ranked.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -61,6 +62,7 @@ import qualified Data.Array.Internal.RankedG as G
 import Data.Array.Internal(ShapeL, Vector(..))
 import Text.PrettyPrint.HughesPJClass hiding ((<>))
 
+type role Array nominal nominal
 newtype Array n a = A { unA :: G.Array n V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/RankedG.hs b/Data/Array/Internal/RankedG.hs
index 57a2aa1..49f1b85 100644
--- a/Data/Array/Internal/RankedG.hs
+++ b/Data/Array/Internal/RankedG.hs
@@ -23,6 +23,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -63,6 +64,7 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>))
 import Data.Array.Internal
 
 -- | Arrays stored in a /v/ with values of type /a/.
+type role Array nominal representational nominal
 data Array (n :: Nat) v a = A !ShapeL !(T v a)
   deriving (Generic, Data)
 
diff --git a/Data/Array/Internal/RankedS.hs b/Data/Array/Internal/RankedS.hs
index e02920c..59fae70 100644
--- a/Data/Array/Internal/RankedS.hs
+++ b/Data/Array/Internal/RankedS.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -64,6 +65,7 @@ import Data.Array.Internal(ShapeL, Vector(..))
 
 type Unbox = V.Storable
 
+type role Array nominal nominal
 newtype Array n a = A { unA :: G.Array n V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/RankedU.hs b/Data/Array/Internal/RankedU.hs
index 3b1645a..f61416a 100644
--- a/Data/Array/Internal/RankedU.hs
+++ b/Data/Array/Internal/RankedU.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -63,6 +64,7 @@ import Data.Array.Internal(ShapeL, Vector(..))
 
 type Unbox = V.Unbox
 
+type role Array nominal nominal
 newtype Array n a = A { unA :: G.Array n V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/Shaped.hs b/Data/Array/Internal/Shaped.hs
index fe7c601..dbb3481 100644
--- a/Data/Array/Internal/Shaped.hs
+++ b/Data/Array/Internal/Shaped.hs
@@ -21,6 +21,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -61,6 +62,7 @@ import qualified Data.Array.Internal.ShapedG as G
 import Data.Array.Internal(ShapeL, Vector)
 import Data.Array.Internal.Shape
 
+type role Array nominal nominal
 newtype Array sh a = A { unA :: G.Array sh V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/ShapedG.hs b/Data/Array/Internal/ShapedG.hs
index a80d29e..3105e31 100644
--- a/Data/Array/Internal/ShapedG.hs
+++ b/Data/Array/Internal/ShapedG.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -64,6 +65,7 @@ import Data.Array.Internal
 import Data.Array.Internal.Shape
 
 -- | Arrays stored in a /v/ with values of type /a/.
+type role Array nominal representational nominal
 newtype Array (sh :: [Nat]) v a = A (T v a)
   deriving (Generic, Data)
 
diff --git a/Data/Array/Internal/ShapedS.hs b/Data/Array/Internal/ShapedS.hs
index d7deacc..71ee131 100644
--- a/Data/Array/Internal/ShapedS.hs
+++ b/Data/Array/Internal/ShapedS.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -65,6 +66,7 @@ import Data.Array.Internal.Shape
 
 type Unbox = V.Storable
 
+type role Array nominal nominal
 newtype Array sh a = A { unA :: G.Array sh V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/Data/Array/Internal/ShapedU.hs b/Data/Array/Internal/ShapedU.hs
index fb4d222..0b672f3 100644
--- a/Data/Array/Internal/ShapedU.hs
+++ b/Data/Array/Internal/ShapedU.hs
@@ -22,6 +22,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -63,6 +64,7 @@ import Data.Array.Internal.Shape
 
 type Unbox = V.Unbox
 
+type role Array nominal nominal
 newtype Array sh a = A { unA :: G.Array sh V.Vector a }
   deriving (Pretty, Generic, Data)
 
diff --git a/orthotope.cabal b/orthotope.cabal
index 196e35b..fb58066 100644
--- a/orthotope.cabal
+++ b/orthotope.cabal
@@ -27,6 +27,8 @@ source-repository head
 library
   hs-source-dirs:      .
   ghc-options:         -Wall
+--  if impl(ghc >= 9.8)
+--      ghc-options: -Wmissing-role-annotations
   exposed-modules:     Data.Array.Convert
                      , Data.Array.Dynamic
                      , Data.Array.DynamicG