{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
-- new GHC extensions
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Kind
import GHC.TypeLits
import Data.Proxy
import Control.Applicative ((<|>))
import Text.Read (readMaybe)
data Rating = Bad | Good | Great
deriving Show
data ServiceStatus = Ok | Down
deriving Show
data Get (a :: Type)
data Capture (a :: Type)
data a :<|> b = a :<|> b
infixr 8 :<|>
data (a :: k) :> (b :: Type)
infixr 9 :>
type BookID = Int
type BookInfoAPI = Get ServiceStatus
:<|> "title" :> Capture BookID :> Get String
:<|> "year" :> Capture BookID :> Get Int
:<|> "rating" :> Capture BookID :> Get Rating
type HandlerAction a = IO a
type family Server layout :: Type
type instance Server (Get a) = HandlerAction a
type instance Server (a :<|> b) = Server a :<|> Server b
type instance Server ((s :: Symbol) :> r) = Server r
type instance Server (Capture a :> r) = a -> Server r
impl :: Server BookInfoAPI
impl = pure Ok
:<|> title
:<|> year
:<|> rating
where
title _ = pure "Haskell in Depth"
year _ = pure 2020
rating _ = pure Great
impl2 :: Server BookInfoAPI
impl2 = pure Down
:<|> title
:<|> year
:<|> rating
where
notImplemented = ioError (userError "not implemented")
title _ = notImplemented
year _ = notImplemented
rating _ = notImplemented
encode :: Show a => IO a -> IO String
encode m = show <$> m
type Request = [String]
class HasServer layout where
route :: Proxy layout -> Server layout -> Request -> Maybe (IO String)
instance Show a => HasServer (Get a) where
route :: Proxy (Get a)
-> HandlerAction a -> Request -> Maybe (IO String)
route _ handler [] = Just (encode $ handler)
route _ _ _ = Nothing
instance {-# OVERLAPS #-} HasServer (Get String) where
route :: Proxy (Get String)
-> IO String -> Request -> Maybe (IO String)
route _ handler [] = Just handler
route _ _ _ = Nothing
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
route :: Proxy (a :<|> b)
-> (Server a :<|> Server b) -> Request -> Maybe (IO String)
route _ (handlera :<|> handlerb) xs =
route (Proxy :: Proxy a) handlera xs
<|> route (Proxy :: Proxy b) handlerb xs
instance (KnownSymbol s, HasServer r) => HasServer ((s :: Symbol) :> r) where
route :: Proxy (s :> r)
-> Server r -> Request -> Maybe (IO String)
route _ handler (x : xs)
| symbolVal (Proxy :: Proxy s) == x = route (Proxy :: Proxy r) handler xs
route _ _ _ = Nothing
instance (Read a, HasServer r) => HasServer (Capture a :> r) where
route :: Proxy (Capture a :> r)
-> (a -> Server r) -> [String] -> Maybe (IO String)
route _ handler (x : xs) = do
a <- readMaybe x
route (Proxy :: Proxy r) (handler a) xs
route _ _ _ = Nothing
get :: HasServer layout => Proxy layout -> Server layout -> [String] -> IO String
get p h xs = case route p h xs of
Nothing -> ioError (userError "404")
Just m -> m
check impl = do
b <- get (Proxy :: Proxy BookInfoAPI) impl []
answer <- get (Proxy :: Proxy BookInfoAPI) impl ["year", "7548"]
putStrLn (if b == "Ok" && answer == "2020"
then "OK"
else "Wrong answer!")
main = check impl