{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
module Language.JVM.TextSerializable where
import Language.Haskell.TH
import Data.String
import Data.Attoparsec.Text
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder as Builder
class TextSerializable a where
parseText :: Parser a
toBuilder :: a -> Builder
deserialize :: Text.Text -> Either String a
deserialize = Parser a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
deserializeWith Parser a
forall a. TextSerializable a => Parser a
parseText
serialize :: a -> Text.Text
serialize = (a -> Builder) -> a -> Text
forall a. (a -> Builder) -> a -> Text
serializeWith a -> Builder
forall a. TextSerializable a => a -> Builder
toBuilder
deserializeWith :: Parser a -> Text.Text -> Either String a
deserializeWith :: Parser a -> Text -> Either String a
deserializeWith Parser a
p = Parser a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
parseOnly (Parser a
p Parser a -> Parser Text () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput)
serializeWith :: (a -> Builder) -> a -> Text.Text
serializeWith :: (a -> Builder) -> a -> Text
serializeWith a -> Builder
serializer = Text -> Text
Lazy.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
serializer
showViaTextSerializable :: TextSerializable a => a -> String
showViaTextSerializable :: a -> String
showViaTextSerializable = Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. TextSerializable a => a -> Text
serialize
{-# INLINE showViaTextSerializable #-}
fromStringViaTextSerializable :: TextSerializable a => String -> a
fromStringViaTextSerializable :: String -> a
fromStringViaTextSerializable String
a =
case Text -> Either String a
forall a. TextSerializable a => Text -> Either String a
deserialize (String -> Text
Text.pack String
a) of
Right a
a' -> a
a'
Left String
msg -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
String
"While parsing a fromString instance we got this error message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Maybe the string " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is wrongly formatted."
{-# INLINE fromStringViaTextSerializable #-}
deriveFromTextSerializable :: Name -> Q [Dec]
deriveFromTextSerializable :: Name -> Q [Dec]
deriveFromTextSerializable Name
name =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ [d|instance Show ($n) where show = showViaTextSerializable |]
, [d|instance IsString ($n) where fromString = fromStringViaTextSerializable |]
] where n :: TypeQ
n = Name -> TypeQ
conT Name
name