src/Worksheets/Utils/JSON.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2
   3 module Worksheets.Utils.JSON (
   4   module Worksheets.Utils.JSON,
   5   module Data.Aeson,
   6   module Data.Aeson.Parser,
   7   module Data.Aeson.Types,
   8 ) where
   9
  10 import Data.Aeson
  11 import Data.Aeson.Parser
  12 import Data.Aeson.Types
  13 import Data.Attoparsec.ByteString qualified as Atto
  14 import Data.ByteString qualified as ByteString
  15 import System.Exit qualified as Sys
  16 import System.IO qualified as Sys
  17
  18 import Worksheets.Utils.Generics qualified as Generics
  19 import Worksheets.Utils.Prelude hiding (Value)
  20
  21 readJSON :: FilePath -> (Value -> Parser a) -> IO a
  22 readJSON path parser = do
  23   withDataFile path \fileHandle -> do
  24     res <- Atto.parseWith (ByteString.hGetSome fileHandle 4096) jsonLast' mempty
  25     case res of
  26       Atto.Partial _k -> do
  27         Sys.hPutStr Sys.stderr "withDataFile: Parser still Partial at EOF"
  28         Sys.exitFailure
  29       Atto.Fail _leftOver contexts message -> do
  30         Sys.hPrint Sys.stderr contexts
  31         Sys.hPutStr Sys.stderr message
  32         Sys.exitFailure
  33       Atto.Done _leftOver resJSON ->
  34         case parseEither (\() -> parser resJSON) () of
  35           Right a -> return a
  36           Left err -> do
  37             Sys.hPutStr Sys.stderr err
  38             Sys.exitFailure
  39
  40 -- | Enables the use of:
  41 -- @
  42 -- deriving (`ToJSON`, `FromJSON`) via (`GenericallyWithOptions` MyDataType)
  43 -- @
  44 newtype GenericallyWithOptions a = GenericallyWithOptions a
  45
  46 instance (Generic a, GFromJSON Zero (Generics.Rep a)) => FromJSON (GenericallyWithOptions a) where
  47   parseJSON x = genericParseJSON options x <&> GenericallyWithOptions
  48 instance (Generic a, GToJSON' Value Zero (Generics.Rep a)) => ToJSON (GenericallyWithOptions a) where
  49   toJSON (GenericallyWithOptions x) = genericToJSON options x
  50
  51 options =
  52   defaultOptions
  53     { fieldLabelModifier = Generics.dropUntilUnderscore
  54     , constructorTagModifier = id
  55     , allNullaryToStringTag = True
  56     , omitNothingFields = False
  57     , sumEncoding = defaultTaggedObject
  58     , unwrapUnaryRecords = False
  59     , tagSingleConstructors = False
  60     , rejectUnknownFields = True
  61     }
  62
  63 -- \^ CoverageNote: safeguard to avoid missing-out data.