Old example for using Singletones to build a typesafe API

SingletonAPI.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
module API where

import qualified Data.Text as T
import qualified Data.Aeson as J
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import GHC.Generics
import Data.Foldable

data EventType = Name | Topic | Other

data EventTypeTag et where
  NameType :: EventTypeTag Name
  TopicType :: EventTypeTag Topic
  OtherType :: T.Text -> EventTypeTag Other

instance Show (EventTypeTag Name) where
  show NameType = "M.name"

instance Show (EventTypeTag Topic) where
  show TopicType = "M.topic"

instance Show (EventTypeTag Other) where
  show (OtherType key) = T.unpack key

newtype MRName = MRName T.Text

instance J.FromJSON MRName where
  parseJSON = J.withObject "MRName" $ \o -> do
    name <- o J..: "name"
    pure $ MRName name

data StateContent et where
  ScName :: MRName -> StateContent Name 
  ScTopic :: T.Text -> StateContent Topic
  ScOther :: J.Value -> StateContent Other

instance J.FromJSON (StateContent Name) where
  parseJSON v = ScName <$> J.parseJSON v

  --parseJSON = J.withObject "RoomName" $ \o -> do
  --  name <- o J..: "name"
  --  pure $ ScName name

instance J.FromJSON (StateContent Topic) where
  parseJSON = J.withObject "RoomTopic" $ \o -> do
    name <- o J..: "topic"
    pure $ ScTopic name
  
instance J.FromJSON (StateContent Other) where
  parseJSON = J.withObject "Other" $ \o -> do
    name <- o J..: "other"
    pure $ ScOther name

data StateEvent et = StateEvent
  { content :: (StateContent et)
  ,  id :: Int -- ...
  } deriving stock (Generic)

deriving anyclass instance (J.FromJSON (StateContent et)) =>  J.FromJSON (StateEvent et)

-- Constraint Synonyms
class (J.FromJSON (StateEvent et), Show (EventTypeTag et)) => FetchableEvent et 
instance (J.FromJSON (StateEvent et), Show (EventTypeTag et)) => FetchableEvent et 

fetchStateEvent :: (J.FromJSON (StateEvent et), Show (EventTypeTag et)) =>
  ID -> EventTypeTag et -> IO (Either String (StateEvent et))
fetchStateEvent id et =
  let url = "/_matrix/client/v3/rooms/" <> "123" <> "/state" <> show et <> "/" <> "xyz"
  in fmap J.eitherDecode $ restCall url

type ID = Int

restCall :: String -> IO BL.ByteString
restCall = error 

--fetchStateEvent :: ID -> EventTypeTag et -> IO (StateEvent et)
--fetchStateEvent id tag = fmap _ $ restCall $ show $ Some tag

data Some f = forall x. Some (f x) 

-- class RenderKey key where
instance Show (Some EventTypeTag) where
  show (Some NameType) = "M.Name"
  show (Some TopicType) = "M.Topic"
  show (Some (OtherType key)) = T.unpack key

instance J.FromJSON (Some StateEvent) where
  parseJSON val = asum [ Some <$> J.parseJSON @(StateEvent Name) val
                       , Some <$> J.parseJSON @(StateEvent Topic) val
                       , Some <$> J.parseJSON @(StateEvent Other) val
                       ]
      
fetchEvents :: IO (Either String [Some StateEvent])
fetchEvents = fmap J.eitherDecode $ restCall $ "/_matrix/client/v3/rooms/" <> "xyz" <> "/state"

--useEvents :: Some StateEvent -> ()
--useEvents (Some (StateEvent (ScName txt) n)) = _wc
--useEvents (Some (StateEvent (ScTopic txt) n)) = _wd
--useEvents (Some (StateEvent (ScOther va) n)) = _we
--
useEvents' :: StateEvent Name -> ()
useEvents' (StateEvent (ScName (MRName txt)) n) = ()