synthetic-type-level-coaching.hs

synthetic-type-level-coaching.hs

#!/usr/bin/env stack
{- stack script
 --resolver=lts-14.7
 --package=aeson
 --package=attoparsec
 --package=text
 --package=unordered-containers
 -}

{-# OPTIONS_GHC -Wall -Wno-missing-signatures #-}
{-# LANGUAGE UnicodeSyntax, LambdaCase, OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE InstanceSigs, TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}

module Main (main) where

{-

  { "status": "success"
  , "product_id": "p100"
  , "description": null
  , "price": "10.12"
  , "price_type": "euro"
  }
  or
  { "status": "error"
  , "errorMessage": "ohshi"
  }

-}


import           GHC.Generics

import           Data.Proxy
import           Data.Typeable (Typeable, typeRep)
import           Data.Text (Text)
import           Data.Aeson
import           Data.Aeson.Types (Parser, typeMismatch)
import qualified Data.HashMap.Strict as HM

import           Control.Monad ((>=>))


data GetProductResponse
   = GetProductResponseFailure GetProductFailureResponse
   | GetProductResponseSuccess GetProductSuccessResponse
     deriving (Eq, Show, Typeable)

instance FromJSON GetProductResponse where
  parseJSON ∷ ∀ τ. τ ~ GetProductResponse ⇒ Value → Parser τ
  parseJSON = go where
    go = unwrapJsonObject (Proxy @τ) >=> f

    f obj =
      case HM.lookup "status" obj of
           Just "error" →
             GetProductResponseFailure <$>
               (parseJSON (Object obj) ∷ Parser GetProductFailureResponse)

           Just "success" →
             GetProductResponseSuccess <$>
               (parseJSON (Object obj) ∷ Parser GetProductSuccessResponse)

           _ →
             show (typeRep $ Proxy @τ) `typeMismatch` Object obj


data GetProductFailureResponse
   = GetProductFailureResponse
   { message ∷ Text
   } deriving (Eq, Show, Generic)

instance FromJSON GetProductFailureResponse where
  parseJSON = undefined
  -- parseJSON ∷ ∀ τ. Typeable τ ⇒ Value → Parser τ
  -- parseJSON = go where
  --   go = unwrapJsonObject (Proxy @τ)


newtype ProductId = ProductId Word deriving (Eq, Show)

data Price
   = Euros   Rational
   | Dollars Rational
     deriving (Eq, Show)

data GetProductSuccessResponse
   = GetProductSuccessResponse
   { productId   ∷ Word
   , description ∷ Maybe Text
   , price       ∷ Price
   } deriving (Eq, Show, Generic)

instance FromJSON GetProductSuccessResponse where
  parseJSON = undefined


main ∷ IO ()
main = putStrLn "foo"


unwrapJsonObject ∷ Typeable τ ⇒ Proxy τ → Value → Parser Object
unwrapJsonObject proxy = \case
  Object x → pure x
  x        → show (typeRep proxy) `typeMismatch` x

(∘) = (.); (•) = flip (∘)