Last active
May 20, 2024 16:35
-
-
Save paolino/05967953e8fec9dcf7d59079a6e9ebb6 to your computer and use it in GitHub Desktop.
An exercise to learn a bit of type level programming in the style of Servant
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment