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,18 @@ 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`