Skip to content

Instantly share code, notes, and snippets.

@tel tel/Maia.hs
Created Mar 18, 2017

Embed
What would you like to do?
Maia in Haskell
{-# 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
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.