An exercise to learn a bit of type level programming in the style of Servant

ByteStringCalculator.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- necessary for the holes, do not import anything else btw
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

module Service.TCP.Calc where

import Data.Attoparsec.ByteString.Char8 qualified as A
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Data (Proxy (..))
import Data.Kind (Type)
import GHC.TypeLits (KnownNat, Natural, natVal)
import Prelude

---- Codecs to parse and render arguments and results from and to ByteString ---

class Codec a where
    parseArg :: ByteString -> Maybe (a, ByteString)
    renderResult :: a -> ByteString

parseAndSkipSpaces :: A.Parser a -> ByteString -> Maybe (a, ByteString)
parseAndSkipSpaces parser input = error "parseAndSkipSpaces not implemented"

instance Codec Int where
    parseArg = parseAndSkipSpaces A.decimal

    renderResult = B.pack . show

instance Codec Double where
    parseArg = parseAndSkipSpaces A.double

    renderResult = B.pack . show

instance Codec ByteString where
    parseArg =
        parseAndSkipSpaces
            $ A.takeWhile (\y -> not $ elem y (" \n" :: String))
    renderResult = id

dropSpaces :: ByteString -> ByteString
dropSpaces = B.dropWhile (== ' ')

----- Application --------------------------------------------

data Result
    = -- | Failed to parse route
      FailedToParseRoute
    | -- | Failed to parse the argument numbered as
      FailedToParseArg Int
    | -- | No route for the given number
      NoRouteMatched
    | -- | The result of the requested operation
      Success ByteString
    deriving (Show, Eq)

{-| An application is a function from ByteString to ByteString that can fail
Nothing signals that the route was not matched
-}
type Application a = ByteString -> a

---- Operation definition  ----
data (segment :: k) :> (segments :: Type)

infixr 9 :>

-- | A type component for a route number
data RouteT (n :: Natural)

-- | A type component for an argument of an operation
data ArgumentT a

-- | A type component for the result of an operation
data ResultT a

-- | A type class for evaluating an operation
class Eval (op :: Type) where
    -- | The type of the function to apply
    type Function op

    eval
        :: Proxy op
        -- ^ necessary because Function is not injective, it cannot be injective
        -- as there are multiple operations that are evaluated to the same function
        -> Int
        -- ^ The index of the current argument
        -> Function op
        -- ^ The function to apply
        -> Application (Maybe Result)

evalRunner
    :: forall op
     . (Eval op)
    => Proxy op
    -> Function op
    -> Application (Maybe Result)
evalRunner pop = eval pop 0

-- | The base case for the core.
instance Codec result => Eval (ResultT result) where
    type Function (ResultT result) = result
    eval = error "eval not implemented"

{-| The recursive case for the ArgumentT type, it parses the argument from the
input and recurse after applying the function to the argument.
-}
instance
    ( Eval opRest -- required for recursive call
    , Codec arg -- required to parse the argument
    )
    => Eval (ArgumentT arg :> opRest)
    where
    type Function (ArgumentT arg :> opRest) = arg -> Function opRest
    eval = error "eval not implemented"

{-| The recursive case for the RouteT type, it parses the route number from the
input and recurse after checking if the route number matches the expected one.
-}
instance
    ( Eval ops
    , KnownNat n
    )
    => Eval (RouteT n :> ops)
    where
    type Function (RouteT n :> ops) = Function ops
    eval = error "eval not implemented"

---------- Server --------------------------------------------

-- | Isomorphic to Either, collects the operations when used recursively
data a :<|> b = a :<|> b

-- | The end of the operations
data End = End

infixr 5 :<|>

-- | A type family to map the operations to functions after they are collected
type family Functions (a :: Type) where
    Functions (a :<|> b) = Function a :<|> Functions b
    Functions End = End

{-| A type class for creating a server from the operations, this will take care
of the routing.
-}
class Server (ops :: Type) where
    serve :: Proxy ops -> Functions ops -> Application Result

instance Server End where
    serve = error "serve not implemented"

instance
    ( Eval thisOp
    , Server restOfOps
    )
    => Server (thisOp :<|> restOfOps)
    where
    serve = error "serve not implemented"


-- Test -------

-- A bunch of operations we want to support
type Sum = RouteT 0 :> ArgumentT Int :> ArgumentT Int :> ResultT Int
type Product = RouteT 1 :> ArgumentT Int :> ArgumentT Int :> ResultT Int
type Division = RouteT 2 :> ArgumentT Double :> ArgumentT Double :> ResultT Double
type Negate = RouteT 3 :> ArgumentT Int :> ResultT Int
type Reverse = RouteT 4 :> ArgumentT ByteString :> ResultT ByteString

type API = Sum :<|> Product :<|> Division :<|> Negate :<|> Reverse :<|> End

-- The implementation of the operations, note the signature of the functions
-- that can be computed from the type family 'Function'
sumOp :: Function Sum -- Int -> Int -> Int
sumOp a b = a + b

productOp :: Function Product -- Int -> Int -> Int
productOp a b = a * b

divisionOp :: Function Division -- Double -> Double -> Double
divisionOp a b = a / b

negateOp :: Function Negate -- Int -> Int
negateOp a = -a

reverseOp :: Function Reverse -- ByteString -> ByteString
reverseOp = B.reverse

service :: Functions API
service = error "service not implemented"

api :: Proxy API
api = Proxy @API

assert :: (Eq b, Applicative f, Show b) => b -> b -> f ()
assert x y = if x == y then pure () else error $ show (x, y)

test :: IO ()
test = do
    assert (serve api service "0 32 10\n") (Success "42")
    assert (serve api service "1 32 10\n") (Success "320")
    assert (serve api service "2 32 10\n") (Success "3.2")
    assert (serve api service "3 32\n") (Success "-32")
    assert (serve api service "4 hello\n") (Success "olleh")
    assert (serve api service "5 hello\n") NoRouteMatched
    assert (serve api service "0 hello\n") (FailedToParseArg 1)
    assert (serve api service "1 32 i\n") (FailedToParseArg 2)
    assert (serve api service "hello\n") FailedToParseRoute