|
| 1 | +module Data.Codec.JSON.Strict |
| 2 | + ( PropCodec |
| 3 | + , ClaimedProps |
| 4 | + , objectStrict |
| 5 | + , prop |
| 6 | + , record |
| 7 | + , recordProp |
| 8 | + , recordPropOptional |
| 9 | + ) where |
| 10 | + |
| 11 | +import Prelude hiding ((<<<), (<=<), (>=>), (>>>)) |
| 12 | + |
| 13 | +import Data.Codec.JSON as CJ |
| 14 | +import Codec.JSON.DecodeError as Error |
| 15 | +import Control.Monad.Except (Except, lift, throwError, withExceptT) |
| 16 | +import Control.Monad.State (StateT, modify_, runStateT) |
| 17 | +import Data.Codec (Codec(..), codec, codec', decode, encode) as Codec |
| 18 | +import Data.List ((:)) |
| 19 | +import Data.List as L |
| 20 | +import Data.Maybe (Maybe(..)) |
| 21 | +import Data.Set as Set |
| 22 | +import Data.String as S |
| 23 | +import Data.Symbol (class IsSymbol, reflectSymbol) |
| 24 | +import Data.Tuple (Tuple(..)) |
| 25 | +import JSON (JObject, JSON) |
| 26 | +import JSON.Object as JO |
| 27 | +import JSON.Path as JP |
| 28 | +import Prim.Row as Row |
| 29 | +import Record.Unsafe as Record |
| 30 | +import Type.Proxy (Proxy) |
| 31 | +import Unsafe.Coerce (unsafeCoerce) |
| 32 | + |
| 33 | +-- | The set of properties that have been claimed "so far" during parsing of a |
| 34 | +-- | record. This is used internally to track which properties have been parsed |
| 35 | +-- | in order to determine which properties are unknown. |
| 36 | +type ClaimedProps = Set.Set String |
| 37 | + |
| 38 | +-- | Codec type for `JObject` prop/value pairs. |
| 39 | +type PropCodec a = |
| 40 | + Codec.Codec |
| 41 | + (StateT ClaimedProps (Except Error.DecodeError)) |
| 42 | + JObject |
| 43 | + (L.List (Tuple String JSON)) |
| 44 | + a |
| 45 | + a |
| 46 | + |
| 47 | +-- | A codec for objects that are encoded with specific properties. This codec |
| 48 | +-- | will fail upon encountering unknown properties in the incoming record. Use |
| 49 | +-- | `Data.Codec.JSON.object` for a version that ignores unknown properties. |
| 50 | +-- | |
| 51 | +-- | See also `Data.Codec.JSON.Record.objectStrict` for a more commonly useful |
| 52 | +-- | version of this function. |
| 53 | +objectStrict ∷ ∀ a. PropCodec a -> CJ.Codec a |
| 54 | +objectStrict codec = Codec.codec' dec enc |
| 55 | + where |
| 56 | + dec j = do |
| 57 | + obj <- Codec.decode CJ.jobject j |
| 58 | + Tuple rec claimedProps <- runStateT (Codec.decode codec obj) Set.empty |
| 59 | + |
| 60 | + let unclaimedProps = Set.difference (Set.fromFoldable (JO.keys obj)) claimedProps |
| 61 | + when (not Set.isEmpty unclaimedProps) $ |
| 62 | + throwError $ Error.error JP.Tip $ |
| 63 | + "Unknown field(s): " <> S.joinWith ", " (Set.toUnfoldable unclaimedProps) |
| 64 | + |
| 65 | + pure rec |
| 66 | + |
| 67 | + enc a = Codec.encode CJ.jobject $ JO.fromFoldable $ Codec.encode codec a |
| 68 | + |
| 69 | +-- | A codec for a property of an object. |
| 70 | +prop ∷ ∀ a. String → CJ.Codec a → PropCodec a |
| 71 | +prop key codec = |
| 72 | + Codec.codec |
| 73 | + ( \obj → do |
| 74 | + v <- case JO.lookup key obj of |
| 75 | + Just j → lift $ withExceptT liftError $ Codec.decode codec j |
| 76 | + Nothing → throwError (Error.noValueFound (JP.AtKey key JP.Tip)) |
| 77 | + modify_ $ Set.insert key |
| 78 | + pure v |
| 79 | + ) |
| 80 | + (\a → pure (Tuple key (CJ.encode codec a))) |
| 81 | + where |
| 82 | + liftError = Error.withPath (JP.AtKey key) |
| 83 | + |
| 84 | + |
| 85 | +-- | The starting value for a object-record codec. Used with `recordProp` it |
| 86 | +-- | provides a convenient method for defining codecs for record types that |
| 87 | +-- | encode into JSON objects of the same shape. |
| 88 | +-- | |
| 89 | +-- | For example, to encode a record as the JSON object |
| 90 | +-- | `{ "name": "Karl", "age": 25 }` we would define a codec like this: |
| 91 | +-- | ``` |
| 92 | +-- | import Data.Codec.JSON as CJ |
| 93 | +-- | import Type.Proxy (Proxy(..)) |
| 94 | +-- | |
| 95 | +-- | type Person = { name ∷ String, age ∷ Int } |
| 96 | +-- | |
| 97 | +-- | codecPerson ∷ CJ.Codec Person |
| 98 | +-- | codecPerson = |
| 99 | +-- | CJ.object $ CJ.record |
| 100 | +-- | # CJ.recordProp (Proxy :: _ "name") CJ.string |
| 101 | +-- | # CJ.recordProp (Proxy :: _ "age") CJ.int |
| 102 | +-- | ``` |
| 103 | +-- | |
| 104 | +-- | See also `Data.Codec.JSON.Record.object` for a more commonly useful |
| 105 | +-- | version of this function. |
| 106 | +record ∷ PropCodec {} |
| 107 | +record = Codec.Codec (const (pure {})) pure |
| 108 | + |
| 109 | +-- | Used with `record` to define codecs for record types that encode into JSON |
| 110 | +-- | objects of the same shape. See the comment on `record` for an example. |
| 111 | +recordProp |
| 112 | + ∷ ∀ p a r r' |
| 113 | + . IsSymbol p |
| 114 | + ⇒ Row.Cons p a r r' |
| 115 | + ⇒ Proxy p |
| 116 | + → CJ.Codec a |
| 117 | + → PropCodec (Record r) |
| 118 | + → PropCodec (Record r') |
| 119 | +recordProp p codecA codecR = Codec.codec dec enc |
| 120 | + where |
| 121 | + key = reflectSymbol p |
| 122 | + liftError = Error.withPath (JP.AtKey key) |
| 123 | + |
| 124 | + dec ∷ JObject -> StateT _ (Except Error.DecodeError) (Record r') |
| 125 | + dec obj = do |
| 126 | + r <- Codec.decode codecR obj |
| 127 | + a :: a <- case JO.lookup key obj of |
| 128 | + Just val -> lift $ withExceptT liftError $ Codec.decode codecA val |
| 129 | + Nothing -> throwError $ Error.noValueFound (JP.AtKey key JP.Tip) |
| 130 | + modify_ $ Set.insert key |
| 131 | + pure $ Record.unsafeSet key a r |
| 132 | + |
| 133 | + enc ∷ Record r' -> L.List (Tuple String JSON) |
| 134 | + enc val = |
| 135 | + Tuple key (Codec.encode codecA (Record.unsafeGet key val)) |
| 136 | + : Codec.encode codecR ((unsafeCoerce ∷ Record r' -> Record r) val) |
| 137 | + |
| 138 | +-- | Used with `record` to define an optional field. |
| 139 | +-- | |
| 140 | +-- | This will only decode the property as `Nothing` if the field does not exist |
| 141 | +-- | in the object - having a values such as `null` assigned will need handling |
| 142 | +-- | separately. |
| 143 | +-- | |
| 144 | +-- | The property will be omitted when encoding and the value is `Nothing`. |
| 145 | +recordPropOptional |
| 146 | + ∷ ∀ p a r r' |
| 147 | + . IsSymbol p |
| 148 | + ⇒ Row.Cons p (Maybe a) r r' |
| 149 | + ⇒ Proxy p |
| 150 | + → CJ.Codec a |
| 151 | + → PropCodec (Record r) |
| 152 | + → PropCodec (Record r') |
| 153 | +recordPropOptional p codecA codecR = Codec.codec dec enc |
| 154 | + where |
| 155 | + key = reflectSymbol p |
| 156 | + liftError = Error.withPath (JP.AtKey key) |
| 157 | + |
| 158 | + dec ∷ JObject -> StateT _ (Except Error.DecodeError) (Record r') |
| 159 | + dec obj = do |
| 160 | + r <- Codec.decode codecR obj |
| 161 | + a :: Maybe a <- case JO.lookup key obj of |
| 162 | + Just val -> lift $ withExceptT liftError $ Just <$> Codec.decode codecA val |
| 163 | + Nothing -> pure Nothing |
| 164 | + modify_ $ Set.insert key |
| 165 | + pure $ Record.unsafeSet key a r |
| 166 | + |
| 167 | + enc ∷ Record r' -> L.List (Tuple String JSON) |
| 168 | + enc val = do |
| 169 | + let r = Codec.encode codecR ((unsafeCoerce ∷ Record r' -> Record r) val) |
| 170 | + case Record.unsafeGet key val of |
| 171 | + Nothing -> r |
| 172 | + Just val' -> Tuple key (Codec.encode codecA val') : r |
0 commit comments