From 2b9ceaead3f3cd80e973cccecb9a3eebc51154f7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 17 Jul 2016 19:21:56 +0200 Subject: Fixes for GHC 8.0.1 --- spec/src/Thermoprint/API.hs | 32 +++++++++++++--------------- spec/src/Thermoprint/Identifiers.hs | 8 +++---- spec/src/Thermoprint/Printout.hs | 42 ++++++++++++++++++++++++++++++------- 3 files changed, 53 insertions(+), 29 deletions(-) (limited to 'spec/src') 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 -- cgit v1.2.3