diff --git a/crem.cabal b/crem.cabal index ba932c6..9d4313c 100644 --- a/crem.cabal +++ b/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 diff --git a/src/Crem/Graph.hs b/src/Crem/Graph.hs index a590816..03f14ad 100644 --- a/src/Crem/Graph.hs +++ b/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. diff --git a/src/Crem/Render/RenderFlow.hs b/src/Crem/Render/RenderFlow.hs index d4f25e5..d523a28 100644 --- a/src/Crem/Render/RenderFlow.hs +++ b/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. -- diff --git a/src/Crem/StateMachine.hs b/src/Crem/StateMachine.hs index a476da2..c7e0aa9 100644 --- a/src/Crem/StateMachine.hs +++ b/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. diff --git a/src/Crem/Topology.hs b/src/Crem/Topology.hs index ac4eba6..0b45818 100644 --- a/src/Crem/Topology.hs +++ b/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`