Store Printouts in persistent-dbs

1 files changed, 12 insertions, 2 deletions

diff --git a/spec/src/Thermoprint/Printout.hs b/spec/src/Thermoprint/Printout.hs
index 1106d2f..397a1af 100644
--- a/spec/src/Thermoprint/Printout.hs
+++ b/spec/src/Thermoprint/Printout.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 {-# OPTIONS_HADDOCK show-extensions #-}
 
 -- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job
@@ -20,13 +21,16 @@ import Data.Sequence (Seq, (|>), (<|))
 import Data.Text.Lazy (Text)
 
 import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS (toStrict)
 
 import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
 import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))
-import qualified Data.Aeson as JSON (encode, decode)
+import qualified Data.Aeson as JSON (encode, decode, eitherDecodeStrict')
 import Data.Aeson.Types (typeMismatch)
 
+import Database.Persist.Class (PersistField(..))
+
 import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary, genericShrink)
 import Test.QuickCheck.Modifiers (NonNegative(..))
 import Test.QuickCheck.Gen (oneof, scale)
@@ -48,6 +52,9 @@ import Data.Function (on)
 
 import Data.Foldable (toList, fold)
 
+import Data.Bifunctor
+import Control.Monad ((<=<))
+
 import Data.Encoding (encodeLazyByteStringExplicit, decodeLazyByteString)
 import Data.Encoding.UTF8
 import qualified Data.ByteString.Base64.Lazy as Base64 (encode, decode)
@@ -58,6 +65,10 @@ import Prelude hiding (fold)
 -- | A 'Printout' is a sequence of visually seperated 'Paragraph's
 type Printout = Seq Paragraph
 
+instance PersistField Printout where
+  toPersistValue   = toPersistValue . LBS.toStrict . JSON.encode
+  fromPersistValue = first T.pack . JSON.eitherDecodeStrict' <=< fromPersistValue 
+
 -- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
 type Paragraph = Seq Chunk
 
@@ -127,7 +138,6 @@ instance Monoid Line where
     | otherwise = JuxtaPos (x <| ys)
   x `mappend` y = JuxtaPos $ Seq.fromList [x, y]
 
-
 text :: Text -> Either Block Line
 -- ^ Smart constructor for 'Line'/'Block' which maps word and line boundaries (as determined by 'isSpace' and '(== '\n')' respectively) to the structure of 'Block' and 'Line'.
 --