Maia in Haskell

Maia.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Maia where

import Data.Vinyl
import Data.Proxy
import GHC.TypeLits
import Data.Kind

data Field where
  Atomic :: Symbol -> Type -> Field
  Nested :: Symbol -> Type -> Field

type family Fields t :: [Field]

--------------------------------------------------------------------------------

class ZeroReq rs where
  zeroReq :: Rec Req rs

instance ZeroReq '[] where
  zeroReq = RNil

instance (ReqF r ~ Bool, ZeroReq rs) => ZeroReq (r ': rs) where
  zeroReq = Req False :& zeroReq

--------------------------------------------------------------------------------

newtype Req f = Req { getReq :: ReqF f }

deriving instance Show (ReqF f) => Show (Req f)

type family ReqF f where
  ReqF (Atomic s a) = Bool
  ReqF (Nested s t) = Maybe (Rec Req (Fields t))

type RequestOf t = Rec Req (Fields t)

--------------------------------------------------------------------------------

newtype Resp f = Resp { getResp :: RespF f }

deriving instance Show (RespF f) => Show (Resp f)

type family RespF f where
  RespF (Atomic s a) = Maybe a
  RespF (Nested s t) = Maybe (Rec Resp (Fields t))

type ResponseOf t = Rec Resp (Fields t)

--------------------------------------------------------------------------------

data Lookup t a =
  Lookup { request :: RequestOf t
         , responseHandler :: ResponseOf t -> Maybe a
         }

instance Functor (Lookup t) where { fmap = undefined }
instance Applicative (Lookup t) where { pure = undefined; (<*>) = undefined }



atom ::
  forall sing s t a .
  (ZeroReq (Fields t), Atomic s a ∈ Fields t) => sing s -> Lookup t a
atom _ = Lookup request' responseHandler' where
  request' = rput (Req True :: Req (Atomic s a)) zeroReq
  responseHandler' = getResp . rget (Proxy :: Proxy (Atomic s a))

nested ::
  forall sing s t' t a .
  (ZeroReq (Fields t), Nested s t' ∈ Fields t) => sing s -> Lookup t' a -> Lookup t a
nested _ l0 = Lookup request' responseHandler' where
  request' :: RequestOf t
  request' = rput (Req (Just (request l0)) :: Req (Nested s t')) zeroReq
  responseHandler' :: ResponseOf t -> Maybe a
  responseHandler' resp =
    case rget (Proxy :: Proxy (Nested s t')) resp of
      Resp Nothing -> error "Impossible!"
      Resp (Just subResp) -> responseHandler l0 subResp

--------------------------------------------------------------------------------

data Location

type instance Fields Location =
  [ Atomic "latitude" Double
  , Atomic "longitude" Double
  ]

data City

type instance Fields City =
  [ Atomic "name" String
  , Nested "location" Location
  , Nested "mayor" Person
  ]

data Person

type instance Fields Person =
  [ Atomic "name" String
  , Nested "hometown" City
  ]