{-# 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