existential.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Lib where

import GHC.TypeLits
import Data.Aeson
import Data.Aeson.Types
import Data.Typeable
import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Scientific as Scientific
import Control.Monad (mzero)


newtype PID = PID Int deriving (Show, Eq, Ord)
newtype VPID = VPID Int deriving (Show, Eq, Ord)

data TagInfo key
  = TagInfo
  { parameterId :: key
  , description :: T.Text
  } deriving (Show, Eq, Ord)

data Component
  = Component
    { cparameter   :: TagInfo Box
    , cdescription :: T.Text
    } deriving (Eq, Show)


type family TypeKey (x :: *) :: Symbol where
  TypeKey VPID = "VPID"
  TypeKey PID  = "PID"

-- | Instances for serializing Proxy
instance {-# OVERLAPPING #-} KnownSymbol s => ToJSON (Proxy s) where
    toJSON = A.String . T.pack . symbolVal

instance {-# OVERLAPPING #-} KnownSymbol s => FromJSON (Proxy s) where
    parseJSON (A.String s) | s == T.pack (symbolVal (Proxy :: Proxy s)) = return (Proxy :: Proxy s)
    parseJSON _      = mzero


data Payload (s :: Symbol) a where
  Payload :: a -> Payload (TypeKey a) a

-- | ToJSON instance
instance (s ~ TypeKey a, KnownSymbol s, ToJSON a) => ToJSON (Payload s a) where
    toJSON (Payload a) = object [ "type" .= (Proxy :: Proxy s)
                                , "data" .= a
                                ]

-- | FromJSON instance
instance (s ~ TypeKey a, KnownSymbol s, FromJSON a) => FromJSON (Payload s a) where
    parseJSON (Object v) = (v .: "type" :: Parser (Proxy s))
                           >>
                           Payload <$> v .: "data"
    parseJSON _          = mzero

data Box where
  MkBox :: (s ~ TypeKey a, KnownSymbol s, Typeable a, Show a, Eq a, ToJSON a)
        => Payload s a
        -> Box

instance Eq Box where
  (==) = boxEq

instance Show Box where
  show (MkBox (Payload a)) = show a

instance ToJSON Box where
  toJSON (MkBox payload) = object ["payload" .= payload]

instance FromJSON Box where
  parseJSON = withObject "Box" $ \o -> do
    payload    <- o .: "payload"
    payloadKey <- payload .: "type"
    case payloadKey :: Maybe String of
      Just "PID"  -> MkBox <$> (o .: "payload" :: Parser (Payload "PID" PID))
      Just "VPID" -> MkBox <$> (o .: "payload" :: Parser (Payload "VPID" VPID))
      _           -> mzero

boxEq :: Box -> Box -> Bool
boxEq (MkBox (Payload a1)) (MkBox (Payload a2)) =
  maybe
    False
    (\a2Casted -> a1 == a2Casted)
    $ cast a2

class HasIntKey a where
  asInt :: a -> Int

instance ToJSON PID where
  toJSON (PID x) = toJSON x

instance FromJSON PID where
  parseJSON = withScientific "PID" $ \n ->
    case Scientific.toBoundedInteger n :: Maybe Int of
      Nothing -> mzero
      Just v  -> pure $ PID v

instance ToJSON VPID where
  toJSON (VPID x) = toJSON x

instance FromJSON VPID where
  parseJSON = withScientific "VPID" $ \n ->
    case Scientific.toBoundedInteger n :: Maybe Int of
      Nothing -> mzero
      Just v  -> pure $ VPID v

instance HasIntKey PID where
  asInt (PID x) = x

instance HasIntKey VPID where
  asInt (VPID x) = x


instance (ToJSON key) => ToJSON (TagInfo key) where
  toJSON (TagInfo key desc) = object ["parameter" .= toJSON key, "desc" .= desc]

instance (FromJSON key) => FromJSON (TagInfo key) where
  parseJSON = withObject "TagInfo" $ \o -> do
    TagInfo <$> o .: "parameter"
            <*> o .: "desc"


pid :: PID
pid = PID 10

vpid :: VPID
vpid = VPID 9

payload1 :: Payload "PID" PID
payload1 = Payload pid

payload2 :: Payload "VPID" VPID
payload2 = Payload vpid

box1 :: Box
box1 = MkBox payload1

box2 :: Box
box2 = MkBox payload2

tag :: TagInfo Box
tag = TagInfo box1 "taginfo"

vtag :: TagInfo Box
vtag = TagInfo box2 "vtaginfo"


someFunc :: IO ()
someFunc = pure ()