@@ -1,3 +1,5 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE StandaloneDeriving #-}
13{-# LANGUAGE AllowAmbiguousTypes #-}
24{-# LANGUAGE DataKinds #-}
35{-# LANGUAGE FlexibleContexts #-}
@@ -16,49 +18,81 @@
1618
1719module Roboservant where
1820
19−import Control.Applicative
21+import Prelude hiding (lookup)
2022import GHC.TypeLits
2123import Servant.API
2224
25+-- | Extract the response types from a single servant endpoint, i.e. one
26+-- without any ':<|>' type constructors in it.
2327type family ExtractRespType (path :: *) :: * where
2428 ExtractRespType (_ :> b) = ExtractRespType b
2529 ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
2630
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.
2734type family ExtractRespTypes (paths :: *) :: [*] where
2835 ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
2936 ExtractRespTypes a = '[ExtractRespType a]
3037
38+-- | Append two type level lists.
3139type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
3240 (x ': xs) <> ys = x ': (xs <> ys)
3341 '[] <> ys = ys
3442
43+-- | A homogeneous-functor-list, I guess.
3544data List :: (* -> *) -> [*] -> * where
3645 Cons :: f a -> List f as -> List f (a ': as)
3746 Nil :: List f '[]
3847
48+-- | So we can use efficient container types for specific types if the need
49+-- arises.
50+class Listy f a where
51+ cons :: a -> f a -> f a
52+ empty :: f a
53+ uncons :: f a -> Maybe (a, f a)
54+
55+instance Listy [] a where
56+ cons = (:)
57+ empty = []
58+ uncons = \case
59+ a : as -> Just (a, as)
60+ [] -> Nothing
61+
62+-- | A function for inserting elements into their slot in the store.
3963class Insert f a as where
4064 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)
4169
70+-- | A function for looking up the container of elements for a specific
71+-- type in the store.
4272class Lookup f a as where
4373 lookup :: List f as -> f a
4474
45−instance Show (List f '[]) where
46− show Nil = "Nil"
75+instance {-# OVERLAPPABLE #-} Lookup f a (a ': as) where
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
79+
80+deriving instance (Show (List f as), forall a. Show a => Show (f a), Show a)
81+ => Show (List f (a ': as))
4782
48−instance (Show (List f as), forall a. Show a => Show (f a), Show a) => Show (List f (a ': as)) where
49− show (Cons fa fas) = "(Cons " <> show fa <> " " <> show fas <> ")"
83+instance Show (List f '[]) where show _ = "Nil"
5084
51−storeOfApi :: forall api xs. (ExtractRespTypes api ~ xs, BuildStore [] xs) => List [] (ExtractRespTypes api)
85+storeOfApi :: BuildStore [] (ExtractRespTypes api) => List [] (ExtractRespTypes api)
5286storeOfApi = buildStore
5387
54−class BuildStore f (xs :: [*]) where
88+class BuildStore f xs where
5589 buildStore :: List f xs
5690
5791instance BuildStore f '[] where
5892 buildStore = Nil
5993
60−instance (BuildStore f xs, Alternative f) => BuildStore f (x ': xs) where
61− buildStore = Cons empty (buildStore @_ @xs)
94+instance (BuildStore f as, Listy f a) => BuildStore f (a ': as) where
95+ buildStore = Cons empty buildStore
6296-- 1.
6397-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
6498
@@ -69,3 +103,4 @@ instance (BuildStore f xs, Alternative f) => BuildStore f (x ': xs) where
69103-- 'Baz -> whole value
70104-- '(Key Bar) -> key2
71105-- '(Key Foo) -> key1
106+--