{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
Module      : Language.JVM.TextSerializable
Copyright   : (c) Christian Gram Kalhauge, 2019
License     : MIT
Maintainer  : kalhuage@cs.ucla.edu

This module can parse and serialize text to structures
-}
module Language.JVM.TextSerializable where


-- template-haskell
import Language.Haskell.TH

-- base
import Data.String

-- attoparsec
import           Data.Attoparsec.Text

-- text
import qualified Data.Text              as Text
import qualified Data.Text.Lazy         as Lazy
import Data.Text.Lazy.Builder           as Builder

-- | A class that indicates that something can be turned from and to
-- text.
class TextSerializable a where
  -- | A `TypeParse` should be parsable
  parseText :: Parser a

  -- | A `TypeParse` should be printable
  toBuilder :: a -> Builder

  -- | Parse a type from text
  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

  -- | Print a type from text
  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

-- | Parse a type from text
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)

-- | Print a type from text
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 #-}

-- -- | Parse a type from text
-- toLazyText :: TextSerializable a => a -> Lazy.Text
-- toLazyText = Builder.toLazyText . typeToBuilder

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