Created
March 21, 2018 00:37
-
-
Save shulhi/749e9456dfcca2f98754724196aaf3dd to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE OverloadedStrings #-} | |
| {-# LANGUAGE ExistentialQuantification #-} | |
| {-# LANGUAGE StandaloneDeriving #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| --{-# LANGUAGE RankNTypes #-} | |
| --{-# LANGUAGE UndecidableInstances #-} | |
| --{-# LANGUAGE AllowAmbiguousTypes #-} | |
| --{-# LANGUAGE GADTs #-} | |
| import Data.Aeson | |
| import Data.Typeable | |
| import qualified Data.Text as T | |
| newtype PID = PID Int deriving (Show, Eq, Ord) | |
| newtype VPID = VPID Int deriving (Show, Eq, Ord) | |
| class HasIntKey a where | |
| asInt :: a -> Int | |
| instance ToJSON PID where | |
| toJSON (PID x) = object ["keyType" .= ("PID" :: String), "keyValue" .= x] | |
| instance FromJSON PID where | |
| parseJSON = withObject "PID" $ \o -> do | |
| keyType <- o .: "keyType" | |
| case keyType of | |
| Just ("PID" :: String) -> PID <$> o .: "keyValue" | |
| Nothing -> fail "Wrong key" | |
| instance ToJSON VPID where | |
| toJSON (VPID x) = object ["keyType" .= ("VPID" :: String), "keyValue" .= x] | |
| instance FromJSON VPID where | |
| parseJSON = withObject "VPID" $ \o -> do | |
| keyType <- o .: "keyType" | |
| case keyType :: Maybe String of | |
| Just "VPID" -> VPID <$> o .: "keyValue" | |
| Nothing -> fail "Wrong key" | |
| instance HasIntKey PID where | |
| asInt (PID x) = x | |
| instance HasIntKey VPID where | |
| asInt (VPID x) = x | |
| data Component = Component | |
| { cKey :: TagInfo PID | |
| , cDescription :: T.Text | |
| } deriving (Show, Eq, Ord) | |
| data TagInfo key = TagInfo | |
| { tagKey :: key | |
| , tagDescription :: T.Text | |
| } deriving (Show, Eq, Ord) | |
| instance (ToJSON key) => ToJSON (TagInfo key) where | |
| toJSON (TagInfo key desc) = object ["tagKey" .= toJSON key, "tagDesc" .= desc] | |
| instance (FromJSON key) => FromJSON (TagInfo key) where | |
| parseJSON = withObject "TagInfo" $ \o -> do | |
| TagInfo <$> o .: "tagKey" | |
| <*> o .: "tagDesc" | |
| data Component' | |
| = forall key. (HasIntKey key, Eq key, Show key, Typeable key, ToJSON key, FromJSON key) | |
| => Component' | |
| { cKey' :: TagInfo key | |
| , cDescription' :: T.Text | |
| } | |
| deriving instance Show (Component') | |
| instance Eq Component' where | |
| c1 == c2 = c1 `eqBy` c2 | |
| eqBy :: Component' -> Component' -> Bool | |
| eqBy (Component' tag1 desc1) (Component' tag2 desc2) = | |
| maybe | |
| False | |
| (\tag2Casted -> tag1 == tag2Casted) | |
| $ cast tag2 | |
| instance ToJSON Component' where | |
| toJSON (Component' tag desc) = object ["componentTag" .= toJSON tag, "componentDescription" .= desc] | |
| instance FromJSON Component' where | |
| parseJSON = withObject "Component'" $ \o -> do | |
| tagMap <- o .: "componentTag" | |
| tagKey <- tagMap .: "tagKey" | |
| tagKeyType <- tagKey .: "keyType" | |
| d <- o .: "componentDescription" | |
| case tagKeyType :: Maybe String of | |
| Just "PID" -> do | |
| tag <- o .: "componentTag" | |
| let tag' = tag :: TagInfo PID | |
| pure $ Component' tag' d | |
| Just "VPID" -> do | |
| tag <- o .: "componentTag" | |
| let tag' = tag :: TagInfo VPID | |
| pure $ Component' tag' d | |
| _ -> fail "Invalid key type" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment