{-# LANGUAGE OverloadedStrings #-}

{- | Helpers for defining Aeson instances for fortran-src types.

To work around dependency awkwardness, we have to write an unusual concrete
context @'ToJSON' 'SrcSpan'@. It seems to work fine.
-}

module Language.Fortran.Extras.JSON.Helpers
  ( toJSONAnnoMerge
  , toJSONAnnoTaggedObj
  , jcProd, jcProdDrop
  , jcSum, jcSumDrop
  , jcEnum, jcEnumDrop
  , tja, gtj, gte
  ) where

import Data.Aeson hiding ( Value )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Language.Fortran.Util.Position ( SrcSpan )
import Data.Text ( Text )

import GHC.Generics ( Generic, Rep )

-- | Shortcut for writing a 'toJSON' definition for a fortran-src AST node type,
--   intended to be used for sum types.
--
-- Flat/concise version which merges all keys into the same object.
toJSONAnnoMerge
    :: (ToJSON a, ToJSON SrcSpan)
    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value
toJSONAnnoMerge :: forall a.
(ToJSON a, ToJSON SrcSpan) =>
Text -> a -> SrcSpan -> [Pair] -> Value
toJSONAnnoMerge Text
t a
a SrcSpan
ss [Pair]
m = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
  [ Key
"anno"     Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= a
a
  , Key
"span"     Key -> SrcSpan -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= SrcSpan
ss
  , Key
"tag"      Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
t ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
m

-- | Shortcut for writing a 'toJSON' definition for a fortran-src AST node type,
--   intended to be used for sum types.
--
-- "Safe" version which approximates Aeson's default 'Data.Aeson.TaggedObject'
-- sum encoding strategy, but with two extra fields extracted out.
toJSONAnnoTaggedObj
    :: (ToJSON a, ToJSON SrcSpan)
    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value
toJSONAnnoTaggedObj :: forall a.
(ToJSON a, ToJSON SrcSpan) =>
Text -> a -> SrcSpan -> [Pair] -> Value
toJSONAnnoTaggedObj Text
t a
a SrcSpan
ss [Pair]
m = [Pair] -> Value
object
  [ Key
"anno"     Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= a
a
  , Key
"span"     Key -> SrcSpan -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= SrcSpan
ss
  , Key
"tag"      Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
t
  , Key
"contents" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object [Pair]
m ]

-- | Shortcut for selected fortran-src AST node type 'toJSON' strategy.
tja :: (ToJSON a, ToJSON SrcSpan)
    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value
tja :: forall a.
(ToJSON a, ToJSON SrcSpan) =>
Text -> a -> SrcSpan -> [Pair] -> Value
tja = Text -> a -> SrcSpan -> [Pair] -> Value
forall a.
(ToJSON a, ToJSON SrcSpan) =>
Text -> a -> SrcSpan -> [Pair] -> Value
toJSONAnnoMerge

-- | Base Aeson generic deriver config for product types.
jcProd :: (String -> String) -> Aeson.Options
jcProd :: (String -> String) -> Options
jcProd String -> String
f = Options
Aeson.defaultOptions
  { rejectUnknownFields :: Bool
Aeson.rejectUnknownFields = Bool
True
  , fieldLabelModifier :: String -> String
Aeson.fieldLabelModifier = Char -> String -> String
Aeson.camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f
  }

jcProdDrop :: String -> Aeson.Options
jcProdDrop :: String -> Options
jcProdDrop String
x = (String -> String) -> Options
jcProd (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x))

-- | Base Aeson generic deriver config for sum types.
jcSum :: (String -> String) -> String -> String -> Aeson.Options
jcSum :: (String -> String) -> String -> String -> Options
jcSum String -> String
f String
tag String
contents = Options
Aeson.defaultOptions
  { rejectUnknownFields :: Bool
Aeson.rejectUnknownFields = Bool
True
  , constructorTagModifier :: String -> String
Aeson.constructorTagModifier = Char -> String -> String
Aeson.camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f
  , sumEncoding :: SumEncoding
Aeson.sumEncoding = Aeson.TaggedObject
    { tagFieldName :: String
Aeson.tagFieldName = String
tag
    , contentsFieldName :: String
Aeson.contentsFieldName = String
contents
    }
  }

jcSumDrop :: String -> Aeson.Options
jcSumDrop :: String -> Options
jcSumDrop String
x = (String -> String) -> String -> String -> Options
jcSum (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x)) String
"tag" String
"contents"

-- | Base Aeson generic deriver config for enum types (no fields in any cons).
jcEnum :: (String -> String) -> Aeson.Options
jcEnum :: (String -> String) -> Options
jcEnum String -> String
f = Options
Aeson.defaultOptions
  { rejectUnknownFields :: Bool
Aeson.rejectUnknownFields = Bool
True
  , constructorTagModifier :: String -> String
Aeson.constructorTagModifier = Char -> String -> String
Aeson.camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f
  }

jcEnumDrop :: String -> Aeson.Options
jcEnumDrop :: String -> Options
jcEnumDrop = (String -> String) -> Options
jcEnum ((String -> String) -> Options)
-> (String -> String -> String) -> String -> Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Int -> String -> String)
-> (String -> Int) -> String -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

-- | Shortcut for common function 'genericToJSON'
gtj :: (Generic a, Aeson.GToJSON' Aeson.Value Aeson.Zero (Rep a)) => Aeson.Options -> a -> Aeson.Value
gtj :: forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
gtj = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON

-- | Shortcut for common function 'genericToEncoding'
gte :: (Generic a, Aeson.GToJSON' Aeson.Encoding Aeson.Zero (Rep a)) => Aeson.Options -> a -> Aeson.Encoding
gte :: forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
gte = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding