feat: add nothunks instances (#76)

crem.cabal

@@ -50,6 +50,7 @@ library
   ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-implicit-prelude -Wno-missing-export-lists -Wno-missing-home-modules -Wno-missing-import-lists -Wno-all-missed-specialisations -Wno-prepositive-qualified-module
   build-depends:
       base >=4.15 && <4.19
+    , nothunks >=0.1 && <0.4
     , profunctors >=3.2 && <5.7
     , singletons-base >=3.0 && <3.3
     , text >=1.2 && <2.1

src/Crem/Graph.hs

@@ -3,12 +3,14 @@ module Crem.Graph where
 
 import Crem.Render.RenderableVertices (RenderableVertices (..))
 import "base" Data.List (nub)
+import "nothunks" NoThunks.Class (NoThunks (..))
 
 -- * Graph
 
 -- | A graph is just a list of edges between vertices of type @a@
 newtype Graph a = Graph [(a, a)]
   deriving stock (Eq, Show)
+  deriving newtype (NoThunks)
 
 -- | The product graph.
 -- It has as vertices the product of the set of vertices of the initial graph.

src/Crem/Render/RenderFlow.hs

@@ -11,6 +11,7 @@ module Crem.Render.RenderFlow where
 
 import Crem.Render.Render
 import Crem.StateMachine
+import "nothunks" NoThunks.Class (NoThunks (..), allNoThunks)
 
 -- | A tree-like structure which could be used to attach metadata to any
 -- similar tree-like structure with only leaves and nodes with exactly two
@@ -20,6 +21,13 @@ data TreeMetadata a
   | BinaryLabel (TreeMetadata a) (TreeMetadata a)
   deriving stock (Show)
 
+instance NoThunks a => NoThunks (TreeMetadata a) where
+  showTypeOf _ = "TreeMetadata"
+  wNoThunks ctxt tm =
+      case tm of
+        LeafLabel x -> noThunks ctxt x
+        BinaryLabel x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+
 -- | Given a `StateMachineT` and a `TreeMetadata` of @MachineLabel@s, we can
 -- create a flow representation of our machine.
 --

src/Crem/StateMachine.hs

@@ -14,6 +14,7 @@ import "base" Control.Category (Category (..))
 import "base" Data.Bifunctor (Bifunctor (second), bimap)
 import "base" Data.Foldable (foldlM)
 import "base" Data.Kind (Type)
+import "nothunks" NoThunks.Class (NoThunks (..), allNoThunks)
 import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 import Prelude hiding ((.))
@@ -74,6 +75,17 @@ data StateMachineT m input output where
     -> StateMachineT m b (n c)
     -> StateMachineT m a (n c)
 
+instance NoThunks (StateMachineT m input output) where
+  showTypeOf _ = "StateMachineT"
+  wNoThunks ctxt sm =
+      case sm of
+        Basic _ -> return Nothing
+        Sequential x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+        Parallel x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+        Alternative x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+        Feedback x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+        Kleisli x y -> allNoThunks [noThunks ctxt x, noThunks ctxt y]
+
 -- | A `StateMachine` is an effectful machine for every possible monad @m@.
 -- Needing to work for every monad, in fact it can not perform any kind of
 -- effect and needs to be pure in nature.

src/Crem/Topology.hs

@@ -26,6 +26,7 @@ module Crem.Topology
   )
 where
 
+import "nothunks" NoThunks.Class (NoThunks (..))
 import "singletons-base" Data.Singletons.Base.TH
 import "singletons-base" Prelude.Singletons
 
@@ -64,6 +65,15 @@ data AllowTransition (topology :: Topology vertex) (initial :: vertex) (final ::
     :: AllowTransition ('Topology map) a b
     -> AllowTransition ('Topology (x ': map)) a b
 
+instance NoThunks (AllowTransition topology initial final) where
+  showTypeOf _ = "AllowTransition"
+  wNoThunks ctxt at =
+      case at of
+        AllowIdentityEdge -> return Nothing
+        AllowFirstEdge -> return Nothing
+        AllowAddingEdge x -> noThunks ctxt x
+        AllowAddingVertex x -> noThunks ctxt x
+
 -- | The `AllowedTransition` type class enables to automatically perform proof search
 -- for a `AllowTransition` term.
 -- It has an instance for every constructor of `AllowTransition`