{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module JsonToHaskell.Internal.Printer where

import JsonToHaskell.Internal.Parser
import JsonToHaskell.Internal.Options
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Foldable (for_, fold)
import qualified Data.Bimap as BM
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import qualified Data.Text as T
import Text.Casing (toCamel, fromAny)
import Data.Char (isAlpha, isAlphaNum)
import Lens.Micro.Platform (view, (+~), (<&>))


-- | Convert a name into a valid haskell field name
toFieldName :: T.Text -> T.Text
toFieldName :: Text -> Text
toFieldName = (Char -> Bool) -> Text -> Text
T.filter (Char -> Bool
isAlphaNum) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toCamel (Identifier String -> String)
-> (Text -> Identifier String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromAny (String -> Identifier String)
-> (Text -> String) -> Text -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlpha)

type StructName = T.Text

-- | Wrap a writer in parens
parens :: MonadWriter T.Text m => m a -> m a
parens :: m a -> m a
parens m a
m =
    Text -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"(" m () -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
m m a -> m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
")"

-- | Embed the given writer at the correct level of indentation and add a newline
line :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
line :: m a -> m a
line m a
m = do
    Int
n <- Getting Int Env Int -> m Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int Env Int
Lens' Env Int
indentationLevel
    Text -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate Int
n Text
" "
    a
a <- m a
m
    m ()
forall (m :: * -> *). MonadWriter Text m => m ()
newline
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return  a
a

-- | Add a newline
newline :: MonadWriter T.Text m => m ()
newline :: m ()
newline = Text -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"\n"

-- | Indent all 'line's of the given writer by one tabstop
indented :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
indented :: m a -> m a
indented m a
m = do
    Int
n <- Getting Int Env Int -> m Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Options -> Const Int Options) -> Env -> Const Int Env
Lens' Env Options
options ((Options -> Const Int Options) -> Env -> Const Int Env)
-> ((Int -> Const Int Int) -> Options -> Const Int Options)
-> Getting Int Env Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Options -> Const Int Options
Lens' Options Int
tabStop)
    (Env -> Env) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Int -> Identity Int) -> Env -> Identity Env
Lens' Env Int
indentationLevel ((Int -> Identity Int) -> Env -> Identity Env) -> Int -> Env -> Env
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
n) m a
m

type Builder a = ReaderT Env (Writer T.Text) ()

-- | Write out the Haskell code for a record data type
writeRecord :: StructName -> RecordFields 'Ref -> Builder ()
writeRecord :: Text -> RecordFields 'Ref -> Builder ()
writeRecord Text
name RecordFields 'Ref
struct = do
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ())
-> ([Text] -> Builder ()) -> [Text] -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> ([Text] -> Text) -> [Text] -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Text] -> Builder ()) -> [Text] -> Builder ()
forall a b. (a -> b) -> a -> b
$ [Text
"data ", Text
name, Text
" = ", Text
name]

    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Builder () -> Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RecordFields 'Ref -> Bool
forall k v. HashMap k v -> Bool
HM.null RecordFields 'Ref
struct) (Builder () -> Builder ())
-> (Builder () -> Builder ()) -> Builder () -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"{"
      [(Int, (Text, Struct 'Ref))]
-> ((Int, (Text, Struct 'Ref)) -> Builder ()) -> Builder ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [(Text, Struct 'Ref)] -> [(Int, (Text, Struct 'Ref))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([(Text, Struct 'Ref)] -> [(Int, (Text, Struct 'Ref))])
-> [(Text, Struct 'Ref)] -> [(Int, (Text, Struct 'Ref))]
forall a b. (a -> b) -> a -> b
$ RecordFields 'Ref -> [(Text, Struct 'Ref)]
forall k v. HashMap k v -> [(k, v)]
HM.toList RecordFields 'Ref
struct) (((Int, (Text, Struct 'Ref)) -> Builder ()) -> Builder ())
-> ((Int, (Text, Struct 'Ref)) -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, (Text
k, Struct 'Ref
v)) -> do
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
            if (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) then Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"{ "
                        else Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
", "
            Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
toFieldName Text
k
            Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
" :: "
            Struct 'Ref -> Builder ()
buildType Struct 'Ref
v
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ())
-> (Builder () -> Builder ()) -> Builder () -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"} "
        Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"deriving (Show, Eq, Ord)"

-- | Write out the Haskell code for a ToJSON instance for the given record
writeToJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()
writeToJSONInstance :: Text -> RecordFields 'Ref -> Builder ()
writeToJSONInstance Text
name RecordFields 'Ref
struct = do
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"instance ToJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"toJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
            Bool -> Builder () -> Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> (RecordFields 'Ref -> Bool) -> RecordFields 'Ref -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordFields 'Ref -> Bool
forall k v. HashMap k v -> Bool
HM.null (RecordFields 'Ref -> Bool) -> RecordFields 'Ref -> Bool
forall a b. (a -> b) -> a -> b
$ RecordFields 'Ref
struct) (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"{..}"
            Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
" = object"
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> Builder () -> Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RecordFields 'Ref -> Bool
forall k v. HashMap k v -> Bool
HM.null RecordFields 'Ref
struct) (Builder () -> Builder ())
-> (Builder () -> Builder ()) -> Builder () -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"["
            [(Int, Text)] -> ((Int, Text) -> Builder ()) -> Builder ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ([Text] -> [(Int, Text)]) -> [Text] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ RecordFields 'Ref -> [Text]
forall k v. HashMap k v -> [k]
HM.keys RecordFields 'Ref
struct) (((Int, Text) -> Builder ()) -> Builder ())
-> ((Int, Text) -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Text
k) -> do
                Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
                    if (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) then Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"[ "
                                else Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
", "
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeQuotes Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
" .= "
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
toFieldName Text
k
            Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ())
-> (Text -> Builder ()) -> Text -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"] "

-- | Write out the Haskell code for a FromJSON instance for the given record
writeFromJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()
writeFromJSONInstance :: Text -> RecordFields 'Ref -> Builder ()
writeFromJSONInstance Text
name RecordFields 'Ref
struct = do
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"instance FromJSON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
    Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"parseJSON (Object v) = do"
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
            [Text] -> (Text -> Builder ()) -> Builder ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RecordFields 'Ref -> [Text]
forall k v. HashMap k v -> [k]
HM.keys RecordFields 'Ref
struct) ((Text -> Builder ()) -> Builder ())
-> (Text -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \Text
k -> do
                Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
toFieldName Text
k
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
" <- v .: "
                    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeQuotes Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
            Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"pure $ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                Bool -> Builder () -> Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> (RecordFields 'Ref -> Bool) -> RecordFields 'Ref -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordFields 'Ref -> Bool
forall k v. HashMap k v -> Bool
HM.null (RecordFields 'Ref -> Bool) -> RecordFields 'Ref -> Bool
forall a b. (a -> b) -> a -> b
$ RecordFields 'Ref
struct) (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"{..}"
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"parseJSON invalid = do"
        Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
          Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ())
-> (Text -> Builder ()) -> Text -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"prependFailure \"parsing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed, \""
          Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
indented (Builder () -> Builder ())
-> (Text -> Builder ()) -> Text -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder () -> Builder ()
forall (m :: * -> *) a.
(MonadReader Env m, MonadWriter Text m) =>
m a -> m a
line (Builder () -> Builder ())
-> (Text -> Builder ()) -> Text -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> Text -> Builder ()
forall a b. (a -> b) -> a -> b
$ Text
"(typeMismatch \"Object\" invalid)"


-- | Write out the Haskell representation for a given JSON type
buildType :: Struct 'Ref -> Builder ()
buildType :: Struct 'Ref -> Builder ()
buildType =
  \case
    Struct 'Ref
SNull -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"()"
    Struct 'Ref
SString -> do
        ReaderT Env (Writer Text) Text
getTextType ReaderT Env (Writer Text) Text
-> (Text -> Builder ()) -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    SNumber NumberType
t -> do
        NumberPreference
pref <- Getting NumberPreference Env NumberPreference
-> ReaderT Env (Writer Text) NumberPreference
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Options -> Const NumberPreference Options)
-> Env -> Const NumberPreference Env
Lens' Env Options
options ((Options -> Const NumberPreference Options)
 -> Env -> Const NumberPreference Env)
-> ((NumberPreference -> Const NumberPreference NumberPreference)
    -> Options -> Const NumberPreference Options)
-> Getting NumberPreference Env NumberPreference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NumberPreference -> Const NumberPreference NumberPreference)
-> Options -> Const NumberPreference Options
Lens' Options NumberPreference
numberPreference)
        case (NumberPreference
pref, NumberType
t) of
            (NumberPreference
FloatNumbers, NumberType
_) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Float"
            (NumberPreference
DoubleNumbers, NumberType
_) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Double"
            (NumberPreference
ScientificNumbers, NumberType
_) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Scientific"
            (NumberPreference
SmartFloats, NumberType
Fractional) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Float"
            (NumberPreference
SmartFloats, NumberType
Whole) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Int"
            (NumberPreference
SmartDoubles, NumberType
Fractional) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Double"
            (NumberPreference
SmartDoubles, NumberType
Whole) -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Int"

    Struct 'Ref
SBool -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Bool"
    Struct 'Ref
SValue -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Value"
    SMap Struct 'Ref
s -> do
        Text
txtType <- ReaderT Env (Writer Text) Text
getTextType
        Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text
"Map " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ") Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder () -> Builder ()
forall (m :: * -> *) a. MonadWriter Text m => m a -> m a
parens (Struct 'Ref -> Builder ()
buildType Struct 'Ref
s)
    SArray Struct 'Ref
s -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
"Vector " Builder () -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder () -> Builder ()
forall (m :: * -> *) a. MonadWriter Text m => m a -> m a
parens (Struct 'Ref -> Builder ()
buildType Struct 'Ref
s)
    SRecordRef Text
n -> Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Text
n
  where
    getTextType :: ReaderT Env (Writer Text) Text
getTextType = do
        Getting TextType Env TextType -> ReaderT Env (Writer Text) TextType
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Options -> Const TextType Options) -> Env -> Const TextType Env
Lens' Env Options
options ((Options -> Const TextType Options) -> Env -> Const TextType Env)
-> ((TextType -> Const TextType TextType)
    -> Options -> Const TextType Options)
-> Getting TextType Env TextType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextType -> Const TextType TextType)
-> Options -> Const TextType Options
Lens' Options TextType
textType) ReaderT Env (Writer Text) TextType
-> (TextType -> Text) -> ReaderT Env (Writer Text) Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          TextType
UseString -> Text
"String"
          TextType
UseByteString -> Text
"ByteString"
          TextType
UseText -> Text
"Text"

-- | Write out all the given records and their instances
writeModel :: Options -> BM.Bimap T.Text (RecordFields 'Ref) -> T.Text
writeModel :: Options -> Bimap Text (RecordFields 'Ref) -> Text
writeModel Options
opts (Bimap Text (RecordFields 'Ref) -> Map Text (RecordFields 'Ref)
forall a b. Bimap a b -> Map a b
BM.toMap -> Map Text (RecordFields 'Ref)
m) = Writer Text () -> Text
forall w a. Writer w a -> w
execWriter (Writer Text () -> Text)
-> (Builder () -> Writer Text ()) -> Builder () -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Builder () -> Env -> Writer Text ())
-> Env -> Builder () -> Writer Text ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Builder () -> Env -> Writer Text ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Options -> Int -> Env
Env Options
opts Int
0) (Builder () -> Text) -> Builder () -> Text
forall a b. (a -> b) -> a -> b
$ do
    Text -> Builder ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Text -> Builder ()) -> ([Text] -> Text) -> [Text] -> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Builder ()) -> [Text] -> Builder ()
forall a b. (a -> b) -> a -> b
$
        [ Text
"{-# LANGUAGE DuplicateRecordFields #-}"
        , Text
"{-# LANGUAGE RecordWildCards #-}"
        , Text
"{-# LANGUAGE OverloadedStrings #-}"
        , Text
"module Model where"
        , Text
""
        , Text
"import Prelude (Double, Bool, Show, Eq, Ord, ($), pure)"
        , Text
"import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.:), (.=), object)"
        , Text
"import Data.Aeson.Types (prependFailure, typeMismatch)"
        , Text
"import Data.Text (Text)"
        , Text
"import Data.Vector (Vector)"
        ]

    Builder ()
forall (m :: * -> *). MonadWriter Text m => m ()
newline
    ReaderT Env (Writer Text) (Map Text ()) -> Builder ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env (Writer Text) (Map Text ()) -> Builder ())
-> ((Text -> RecordFields 'Ref -> Builder ())
    -> ReaderT Env (Writer Text) (Map Text ()))
-> (Text -> RecordFields 'Ref -> Builder ())
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> RecordFields 'Ref -> Builder ())
 -> Map Text (RecordFields 'Ref)
 -> ReaderT Env (Writer Text) (Map Text ()))
-> Map Text (RecordFields 'Ref)
-> (Text -> RecordFields 'Ref -> Builder ())
-> ReaderT Env (Writer Text) (Map Text ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> RecordFields 'Ref -> Builder ())
-> Map Text (RecordFields 'Ref)
-> ReaderT Env (Writer Text) (Map Text ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey Map Text (RecordFields 'Ref)
m ((Text -> RecordFields 'Ref -> Builder ()) -> Builder ())
-> (Text -> RecordFields 'Ref -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \Text
k RecordFields 'Ref
v -> do
        Text -> RecordFields 'Ref -> Builder ()
writeRecord Text
k RecordFields 'Ref
v
        Builder ()
forall (m :: * -> *). MonadWriter Text m => m ()
newline
    ReaderT Env (Writer Text) (Map Text ()) -> Builder ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env (Writer Text) (Map Text ()) -> Builder ())
-> ((Text -> RecordFields 'Ref -> Builder ())
    -> ReaderT Env (Writer Text) (Map Text ()))
-> (Text -> RecordFields 'Ref -> Builder ())
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> RecordFields 'Ref -> Builder ())
 -> Map Text (RecordFields 'Ref)
 -> ReaderT Env (Writer Text) (Map Text ()))
-> Map Text (RecordFields 'Ref)
-> (Text -> RecordFields 'Ref -> Builder ())
-> ReaderT Env (Writer Text) (Map Text ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> RecordFields 'Ref -> Builder ())
-> Map Text (RecordFields 'Ref)
-> ReaderT Env (Writer Text) (Map Text ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey Map Text (RecordFields 'Ref)
m ((Text -> RecordFields 'Ref -> Builder ()) -> Builder ())
-> (Text -> RecordFields 'Ref -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \Text
k RecordFields 'Ref
v -> do
        Text -> RecordFields 'Ref -> Builder ()
writeToJSONInstance Text
k RecordFields 'Ref
v
        Builder ()
forall (m :: * -> *). MonadWriter Text m => m ()
newline
    ReaderT Env (Writer Text) (Map Text ()) -> Builder ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Env (Writer Text) (Map Text ()) -> Builder ())
-> ((Text -> RecordFields 'Ref -> Builder ())
    -> ReaderT Env (Writer Text) (Map Text ()))
-> (Text -> RecordFields 'Ref -> Builder ())
-> Builder ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> RecordFields 'Ref -> Builder ())
 -> Map Text (RecordFields 'Ref)
 -> ReaderT Env (Writer Text) (Map Text ()))
-> Map Text (RecordFields 'Ref)
-> (Text -> RecordFields 'Ref -> Builder ())
-> ReaderT Env (Writer Text) (Map Text ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> RecordFields 'Ref -> Builder ())
-> Map Text (RecordFields 'Ref)
-> ReaderT Env (Writer Text) (Map Text ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
M.traverseWithKey Map Text (RecordFields 'Ref)
m ((Text -> RecordFields 'Ref -> Builder ()) -> Builder ())
-> (Text -> RecordFields 'Ref -> Builder ()) -> Builder ()
forall a b. (a -> b) -> a -> b
$ \Text
k RecordFields 'Ref
v -> do
        Text -> RecordFields 'Ref -> Builder ()
writeFromJSONInstance Text
k RecordFields 'Ref
v
        Builder ()
forall (m :: * -> *). MonadWriter Text m => m ()
newline

escapeQuotes :: T.Text -> T.Text
escapeQuotes :: Text -> Text
escapeQuotes = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\""