Fixes for GHC 8.0.1

4 files changed, 54 insertions, 30 deletions

diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs
index 9e91487..8e98db8 100644
--- a/spec/src/Thermoprint/API.hs
+++ b/spec/src/Thermoprint/API.hs
@@ -100,12 +100,6 @@ instance Exception PrintingError
 
 type DraftTitle = Text
 
-instance FromText UTCTime where
-  fromText = parseTimeM True defaultTimeLocale "%F_%T%Q" . T.unpack
-
-instance ToText UTCTime where
-  toText = T.pack . formatTime defaultTimeLocale "%F_%T%Q"
-
 data Range a = Min a | Max a | Through a a
   deriving (Show, Eq, Generic)
 
@@ -121,17 +115,19 @@ contains (Min min) x = min <= x
 contains (Max max) x = max >= x
 contains (Through min max) x = min <= x && x <= max
 
-instance ToText a => ToText (Range a) where
-  toText (Min min) = toText min <> "-"
-  toText (Max max) = "-" <> toText max
-  toText (Through min max) = toText min <> "-" <> toText max
+instance ToHttpApiData a => ToHttpApiData (Range a) where
+  toUrlPiece (Min min) = toUrlPiece min <> "-"
+  toUrlPiece (Max max) = "-" <> toUrlPiece max
+  toUrlPiece (Through min max) = toUrlPiece min <> "-" <> toUrlPiece max
   
-instance FromText a => FromText (Range a) where
-  fromText t = listToMaybe $ through <> max <> min
+instance FromHttpApiData a => FromHttpApiData (Range a) where
+  parseUrlPiece t = listToEither $ through <> max <> min
     where
-      through = [ Through min max | ((fromText -> Just min), (T.uncons -> Just ('-', (fromText -> Just max)))) <- zip (T.inits t) (T.tails t) ]
-      min = [ Min min | (fromText -> Just min) <- T.inits t ]
-      max = [ Max max | (fromText -> Just max) <- T.tails t ]
+      through = [ Through min max | ((parseUrlPiece -> Right min), (T.uncons -> Just ('-', (parseUrlPiece -> Right max)))) <- zip (T.inits t) (T.tails t) ]
+      min = [ Min min | (parseUrlPiece -> Right min) <- T.inits t ]
+      max = [ Max max | (parseUrlPiece -> Right max) <- T.tails t ]
+      listToEither [x] = Right x 
+      listToEither _   = Left t
 
 type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus)
                       :<|> "jobs" :> (
@@ -144,16 +140,16 @@ type ThermoprintAPI = "printers" :> Get '[JSON] (Map PrinterId PrinterStatus)
                       :<|> "job" :> Capture "jobId" JobId :> (
                         Get '[JSON] Printout
                         :<|> "status" :> Get '[JSON] JobStatus
-                        :<|> Delete '[PlainText] ()
+                        :<|> Delete '[JSON] ()
                       )
                       :<|> "drafts" :> (
                         Get '[JSON] (Map DraftId (Maybe DraftTitle))
                         :<|> QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Post '[JSON] DraftId
                       )
                       :<|> "draft" :> Capture "draftId" DraftId :> (
-                        QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Put '[PlainText] ()
+                        QueryParam "title" DraftTitle :> ReqBody '[JSON] Printout :> Put '[JSON] ()
                         :<|> Get '[JSON] (Maybe DraftTitle, Printout)
-                        :<|> Delete '[PlainText] ()
+                        :<|> Delete '[JSON] ()
                         :<|> QueryParam "printer" PrinterId :> Post '[JSON] JobId
                       )
 
diff --git a/spec/src/Thermoprint/Identifiers.hs b/spec/src/Thermoprint/Identifiers.hs
index ed8534e..2a07318 100644
--- a/spec/src/Thermoprint/Identifiers.hs
+++ b/spec/src/Thermoprint/Identifiers.hs
@@ -12,17 +12,17 @@ import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Control.DeepSeq (NFData)
 
-import Servant.API (ToText, FromText)
+import Servant.API (ToHttpApiData, FromHttpApiData)
 import Data.Aeson (FromJSON, ToJSON)
 
 newtype PrinterId = PrinterId Integer
-                  deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData)
+                  deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData)
 
 newtype JobId = JobId Integer
-              deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData)
+              deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData)
 
 newtype DraftId = DraftId Integer
-              deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromText, ToText, FromJSON, ToJSON, Typeable, Generic, NFData)
+              deriving (Show, Read, Eq, Ord, Num, Real, Integral, Enum, FromHttpApiData, ToHttpApiData, FromJSON, ToJSON, Typeable, Generic, NFData)
 
 castId :: (Integral a, Enum b) => a -> b
 castId = toEnum . fromInteger . toInteger
diff --git a/spec/src/Thermoprint/Printout.hs b/spec/src/Thermoprint/Printout.hs
index 2be0a83..8c33e07 100644
--- a/spec/src/Thermoprint/Printout.hs
+++ b/spec/src/Thermoprint/Printout.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
 {-# OPTIONS_HADDOCK show-extensions #-}
 
 -- | This module contains the definition of the structure -- 'Printout' -- used to represent the content of a job
@@ -63,19 +63,47 @@ import Prelude hiding (fold)
 
 
 -- | A 'Printout' is a sequence of visually seperated 'Paragraph's
-type Printout = Seq Paragraph
+newtype Printout = Printout { getParagraphs :: Seq Paragraph }
+  deriving (Show, Generic, NFData)
+
+instance Eq Paragraph => Eq Printout where
+  (==) = (==) `on` getParagraphs
+
+instance Monoid Printout where
+  mempty = Printout mempty
+  mappend a b = Printout $ (mappend `on` getParagraphs) a b
+
+instance FromJSON Printout where
+  parseJSON = fmap Printout . parseJSON
+
+instance ToJSON Printout where
+  toJSON = toJSON . getParagraphs
+
+instance Arbitrary Printout where
+  arbitrary = Printout <$> arbitrary
 
 -- | A 'Paragraph' is a non-seperated sequence of 'Chunk's
-type Paragraph = Seq Chunk
+newtype Paragraph = Paragraph { getChunks :: Seq Chunk }
+  deriving (Show, Generic, NFData)
+
+instance Eq Chunk => Eq Paragraph where
+  (==) = (==) `on` getChunks
+
+instance Monoid Paragraph where
+  mempty = Paragraph mempty
+  mappend a b = Paragraph $ (mappend `on` getChunks) a b
+
+instance Arbitrary Paragraph where
+  arbitrary = Paragraph <$> arbitrary
 
 instance FromJSON Paragraph where
-  parseJSON o@(Array _)  = Seq.fromList  <$> parseJSON o
-  parseJSON o@(Object _) = Seq.singleton <$> parseJSON o
-  parseJSON o@(String _) = Seq.singleton <$> parseJSON o
+  parseJSON o@(Array _)  = Paragraph . Seq.fromList  <$> parseJSON o
+  parseJSON o@(Object _) = Paragraph . Seq.singleton <$> parseJSON o
+  parseJSON o@(String _) = Paragraph . Seq.singleton <$> parseJSON o
   parseJSON v = typeMismatch "Paragraph" v
 
 instance ToJSON Paragraph where
-  toJSON cs
+  toJSON (Paragraph cs)
     | (a :< as) <- viewl cs
     , Seq.null as = toJSON a
     | otherwise = toJSON $ toList cs
diff --git a/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal
index e236e05..28680fb 100644
--- a/spec/thermoprint-spec.cabal
+++ b/spec/thermoprint-spec.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                thermoprint-spec
-version:             3.0.0
+version:             4.0.0
 synopsis:            A specification of the API and the payload datatypes and associated utilities
 -- description:         
 homepage:            http://dirty-haskell.org/tags/thermoprint.html