Aeson Parsing Optional Fields with a Sentinel

SentinelFields1.hs

{-# LANGUAGE DeriveGeneric #-}

module SentinelFields1 where
{-

We have some JSON..

[
  {
    "name": "Foo Test",
    "type": "Decimal",
    "options": {
      "places": 2
    }
  },
  {
    "name": "Bar Test",
    "type": "Text",
    "options": {
      "maxLength": 4
    }
  },
  {
    "name": "Baz Test",
    "type": "Checkbox"
  }
]

and we want to get

[
  FormField ( _formFieldName = "Foo Test"
            , _formFieldType = Decimal
            , _formFieldOptions = Just DecimalOptions (_decimalOptionsPlaces = 2)
            ),
  FormField ( _formFieldName = "Bar Test"
            , _formFieldType = Text
            , _formFieldOptions = Just TextOptions (_textOptionsMaxLenghth = 4)
            ),
  FormField ( _formFieldName = "Baz Test"
            , _formFieldType = Checkbox
            , _formFieldOptions = Nothing
            ),
]

how to interpret the optional "options" field can be decided by a case match
on the sentinel field, "type".

-}

import Data.Aeson
import Data.Text (Text)
import GHC.Generics

data FieldType = Text | Decimal | Checkbox
  deriving (Eq, Generic, Ord, Show)

data FieldOptions = DecimalOptions { places :: Int }
                  | TextOptions { maxLength :: Int }
  deriving (Eq, Generic, Show)

data FormField =
  FormField
  { _name    :: Text
  , _type    :: FieldType
  , _options :: Maybe FieldOptions
  }
  deriving (Eq, Generic, Show)

instance ToJSON FieldType
instance FromJSON FieldType
instance ToJSON FieldOptions where
  toJSON = genericToJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance FromJSON FieldOptions where
  parseJSON = genericParseJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance ToJSON FormField where
  toJSON = genericToJSON defaultOptions
    {
      fieldLabelModifier = drop 1
    }
instance FromJSON FormField where
  parseJSON = genericParseJSON defaultOptions
    {
      fieldLabelModifier = drop 1
    }

{-

This minimal definition isn't good enough because

{
  "name": "Oops",
  "type": "Text",
  "options": {
    "places": 2
  }
}

will still parse as valid!

-}

SentinelFields2.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module SentinelFields2 where

import Data.Aeson
import Data.Maybe (maybe)
import Data.Text (Text)
import GHC.Generics

data FieldType = TextField | DecimalField | CheckboxField
  deriving (Eq, Generic, Ord, Show)

data FieldOptions = DecimalOptions { places :: Int }
                  | TextOptions { maxLength :: Int }
  deriving (Eq, Generic, Show)

data FormField =
  FormField
  { _name    :: Text
  , _type    :: FieldType
  , _options :: Maybe FieldOptions
  }
  deriving (Eq, Generic, Show)

instance ToJSON FieldType where
  toJSON = genericToJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance FromJSON FieldType where
  parseJSON = genericParseJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance ToJSON FieldOptions where
  toJSON = genericToJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance FromJSON FieldOptions where
  parseJSON = genericParseJSON defaultOptions
    {
      sumEncoding = UntaggedValue
    }
instance ToJSON FormField where
  toJSON = genericToJSON defaultOptions
    {
      fieldLabelModifier = drop 1
    }
instance FromJSON FormField where
  parseJSON = withObject "FormField" $ \o -> do
    _name <- o .: "name"
    _type <- o .: "type"
    _options' <- o .:? "options"
    _options <- mapM (mkOptions _type) _options'
    return FormField {..}
    where
      mkOptions DecimalField o = DecimalOptions <$> o .: "places"
      mkOptions TextField o = TextOptions <$> o .: "maxLength"
      mkOptions _ o = fail "Invalid options for field type"
{-

This one works!

-}