solution.hs

#! /usr/bin/env nix-shell
#! nix-shell --show-trace --pure -Q -i "runghc --ghc-arg=-main-is --ghc-arg=Solution.main" -p "ghc.withPackages (pkgs: with pkgs; [ either text ])" -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/cf7475d2061ac3ada4b226571a4a1bb91420b578.tar.gz

-- You'll need nix to automatically download the dependencies:
-- `{ curl https://nixos.org/nix/install | sh ; } && . ~/.nix-profile/etc/profile.d/nix.sh`

{-# LANGUAGE OverloadedStrings
  , PatternSynonyms #-}

import Prelude hiding (lookup)
import Data.Map (Map(..), fromList, lookup, toList)
import Data.Foldable (fold)
import Data.Functor ((<&>))
import Data.Either.Combinators (leftToMaybe, maybeToRight, maybeToLeft)
import Data.Text (Text(..), pack)

main = print $ scheme `validate` json
  where
  scheme = JSONOTypeObject
    $ fromList
      [ ("key", JSONTypeString)
      , ("list", JSONTypeOptional $ JSONTypeList
        [ JSONTypeInt
        , JSONTypeString ]) ]
  json = JSONObject
    $ fromList
     [ ("key", JSONString "value")
     ,  ("list", JSONList
        [ JSONInt 42
        , JSONNull ]) ] -- here should be an error

type JSONKey = Text

data JSONType
  = JSONTypeString
  | JSONTypeInt
  | JSONTypeList [JSONType]
  | JSONTypeOptional JSONType
  | JSONOTypeObject (Map JSONKey JSONType)
  deriving Show

data JSONValue
  = JSONString Text
  | JSONInt Integer
  | JSONList [JSONValue]
  | JSONNull
  | JSONObject (Map JSONKey JSONValue)
  deriving Show

-- nice place to use SOP
--
-- also it would be nice to explicitly encode subtyping of optional values
-- as well as dictionary keys subtyping
validate :: JSONType -> JSONValue -> Either Text ()
validate type' value =
  case (value, type') of  -- unlike OCaml or Scala, Haskell have no disjunctive patterns
    (JSONString _, JSONTypeString) -> unit
    (JSONInt _, JSONTypeInt) -> unit
    (JSONNull, JSONTypeOptional _) -> unit
    (JSONList vs, JSONTypeList ts) -> foldLeft $ uncurry validate <$> zip ts vs
    (JSONObject o, JSONOTypeObject t) ->
      foldLeft $ toList t
        <&> \(k, v) -> errorField k v o `maybeToRight` lookup k o >>= validate v
    (_, JSONTypeOptional t) ->
      validate t value  -- actually, it should be GADT to avoid Optional nesting
    _ -> Left $ "The JSON value "
      <> pack' value
      <> " is not of expected type "
      <> pack' type'
  where
  unit = pure mempty
  foldLeft es = maybeToLeft mempty . fold $ leftToMaybe <$> es
  errorField :: JSONKey -> JSONType -> Map JSONKey JSONValue -> Text
  errorField k v o = "There's no key "
    <> pack' k
    <> " of type "
    <> pack' v
    <> " in the JSON object "
    <> pack' o
  pack' :: Show a => a -> Text
  pack' = pack . show

pattern JSONLeaf <- ((JSONString _, JSONTypeString) | (JSONInt _, JSONTypeInt))