@@ -1,3 +1,5 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE StandaloneDeriving #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
@@ -16,49 +18,81 @@
17module Roboservant where
19module Roboservant where
19−import Control.Applicative
21+import Prelude hiding (lookup)
20import GHC.TypeLits
22import GHC.TypeLits
21import Servant.API
23import Servant.API
25+-- | Extract the response types from a single servant endpoint, i.e. one
26+-- without any ':<|>' type constructors in it.
23type family ExtractRespType (path :: *) :: * where
27type family ExtractRespType (path :: *) :: * where
24 ExtractRespType (_ :> b) = ExtractRespType b
28 ExtractRespType (_ :> b) = ExtractRespType b
25 ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
29 ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
31+-- | Extract the response types from a flattened servant API, i.e. one
32+-- which has the distributive law (modulo isomorphism) applied to it until
33+-- it reaches a normal form.
27type family ExtractRespTypes (paths :: *) :: [*] where
34type family ExtractRespTypes (paths :: *) :: [*] where
28 ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
35 ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
29 ExtractRespTypes a = '[ExtractRespType a]
36 ExtractRespTypes a = '[ExtractRespType a]
38+-- | Append two type level lists.
31type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
39type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
32 (x ': xs) <> ys = x ': (xs <> ys)
40 (x ': xs) <> ys = x ': (xs <> ys)
33 '[] <> ys = ys
41 '[] <> ys = ys
43+-- | A homogeneous-functor-list, I guess.
35data List :: (* -> *) -> [*] -> * where
44data List :: (* -> *) -> [*] -> * where
36 Cons :: f a -> List f as -> List f (a ': as)
45 Cons :: f a -> List f as -> List f (a ': as)
37 Nil :: List f '[]
46 Nil :: List f '[]
48+-- | So we can use efficient container types for specific types if the need
51+ cons :: a -> f a -> f a
53+ uncons :: f a -> Maybe (a, f a)
55+instance Listy [] a where
59+ a : as -> Just (a, as)
62+-- | A function for inserting elements into their slot in the store.
39class Insert f a as where
63class Insert f a as where
40 insert :: a -> List f as -> List f as
64 insert :: a -> List f as -> List f as
65+instance {-# OVERLAPPABLE #-} Listy f a => Insert f a (a ': as) where
66+ insert a (Cons as ls) = Cons (cons a as) ls
67+instance {-# OVERLAPPABLE #-} Insert f a as => Insert f a (b ': as) where
68+ insert a (Cons as ls) = Cons as (insert a ls)
70+-- | A function for looking up the container of elements for a specific
42class Lookup f a as where
72class Lookup f a as where
43 lookup :: List f as -> f a
73 lookup :: List f as -> f a
45−instance Show (List f '[]) where
75+instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
46− show Nil = "Nil"
76+ lookup (Cons fa ls) = fa
77+instance {-# OVERLAPPABLE #-} Lookup f a as => Lookup f a (b ': as) where
78+ lookup (Cons fa ls) = lookup ls
80+deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
81+ => Show (List f (a ': as))
48−instance (Show (List f as), forall a. Show a => Show (f a), Show a) => Show (List f (a ': as)) where
83+instance Show (List f '[]) where show _ = "Nil"
49− show (Cons fa fas) = "(Cons " <> show fa <> " " <> show fas <> ")"
51−storeOfApi :: forall api xs. (ExtractRespTypes api ~ xs, BuildStore [] xs) => List [] (ExtractRespTypes api)
85+storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
52storeOfApi = buildStore
86storeOfApi = buildStore
54−class BuildStore f (xs :: [*]) where
88+class BuildStore f xs where
55 buildStore :: List f xs
89 buildStore :: List f xs
57instance BuildStore f '[] where
91instance BuildStore f '[] where
58 buildStore = Nil
92 buildStore = Nil
60−instance (BuildStore f xs, Alternative f) => BuildStore f (x ': xs) where
94+instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
61− buildStore = Cons empty (buildStore @_ @xs)
95+ buildStore = Cons empty buildStore
63-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
97-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
@@ -69,3 +103,4 @@ instance (BuildStore f xs, Alternative f) => BuildStore f (x ': xs) where
69-- 'Baz -> whole value
103-- 'Baz -> whole value
70-- '(Key Bar) -> key2
104-- '(Key Bar) -> key2
71-- '(Key Foo) -> key1
105-- '(Key Foo) -> key1