tidying up

Makefile

@@ -0,0 +1,2 @@
+testwatch:
+	ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml"

package.yaml

@@ -24,7 +24,8 @@ dependencies:
 - servant
 # - servant-server
 - servant-flatten
-
+# test deps
+- hspec
 library:
   source-dirs: src
 

roboservant.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 33a62383bf0beb0aeb574784168345597afa6e00cb42cc943f6708e06370ae37
+-- hash: 610f174fd4598a8ab9987ef588849ffd10eebdd86741c98dbe9219a1c979785e
 
 name:           roboservant
 version:        0.1.0.0
@@ -28,12 +28,14 @@ source-repository head
 library
   exposed-modules:
       Lib
+      Roboservant
   other-modules:
       Paths_roboservant
   hs-source-dirs:
       src
   build-depends:
       base >=4.7 && <5
+    , hspec
     , servant
     , servant-flatten
   default-language: Haskell2010
@@ -48,6 +50,7 @@ test-suite roboservant-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , hspec
     , roboservant
     , servant
     , servant-flatten

scripts/pre-commit.sh

@@ -0,0 +1,12 @@
+#!/bin/env bash
+#
+# Remember to link me to .git/hooks/pre-commit
+
+set -euo pipefail
+
+files=$((git diff --cached --name-only --diff-filter=ACMR | grep -Ei "\.hs$") || true)
+if [ ! -z "${files}" ]; then
+    echo "$files"
+    echo "$files" | xargs ormolu --mode inplace
+    git add $(echo "$files" | paste -s -d " " -)
+fi

src/Lib.hs

@@ -103,4 +103,3 @@ main = pure ()
 --     'Baz -> whole value
 --     '(Key Bar) -> key2
 --     '(Key Foo) -> key1
-

src/Roboservant.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Roboservant where
+
+import Control.Applicative
+import GHC.TypeLits
+import Servant.API
+
+type family ExtractRespType (path :: *) :: * where
+  ExtractRespType (_ :> b) = ExtractRespType b
+  ExtractRespType (Verb (method :: StdMethod) (responseCode :: Nat) (contentTypes :: [*]) (respType :: *)) = respType
+
+type family ExtractRespTypes (paths :: *) :: [*] where
+  ExtractRespTypes (a :<|> b) = ExtractRespTypes a <> ExtractRespTypes b
+  ExtractRespTypes a = '[ExtractRespType a]
+
+type family (<>) (xs :: [k]) (ys :: [k]) :: [k] where
+  (x ': xs) <> ys = x ': (xs <> ys)
+  '[] <> ys = ys
+
+data List :: (* -> *) -> [*] -> * where
+  Cons :: f a -> List f as -> List f (a ': as)
+  Nil :: List f '[]
+
+class Insert f a as where
+  insert :: a -> List f as -> List f as
+
+class Lookup f a as where
+  lookup :: List f as -> f a
+
+instance Show (List f '[]) where
+  show Nil = "Nil"
+
+instance (Show (List f as), forall a. Show a => Show (f a), Show a) => Show (List f (a ': as)) where
+  show (Cons fa fas) = "(Cons " <> show fa <> " " <> show fas <> ")"
+
+storeOfApi :: forall api xs. (ExtractRespTypes api ~ xs, BuildStore [] xs) => List [] (ExtractRespTypes api)
+storeOfApi = buildStore
+
+class BuildStore f (xs :: [*]) where
+  buildStore :: List f xs
+
+instance BuildStore f '[] where
+  buildStore = Nil
+
+instance (BuildStore f xs, Alternative f) => BuildStore f (x ': xs) where
+  buildStore = Cons empty (buildStore @_ @xs)
+-- 1.
+-- Instead of just the resptype, let's return a tuple of (resptype, '[]::[ ? respType])
+
+-- 2.
+-- break down respType into "useful" components
+--   data Baz = Baz { key1 :: Key Foo, key2 :: Key Bar }
+--   should insert into type-indexed list three elements
+--     'Baz -> whole value
+--     '(Key Bar) -> key2
+--     '(Key Foo) -> key1

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-15.6
+resolver: lts-15.15
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

test/Spec.hs

@@ -1,2 +1,51 @@
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+import           Roboservant
+import           Servant.API
+import           Test.Hspec
+
+newtype Foo = Foo Int
+  deriving (Show)
+
+newtype Bar = Bar String
+  deriving (Show)
+
+type FooApi = "foo" :> "fle" :> "far" :> Get '[JSON] Foo
+
+type BarApi = "bar" :> ReqBody '[JSON] Foo :> Post '[JSON] Bar
+
+type Api =
+  FooApi :<|> BarApi
+
+type Foo' = ExtractRespType FooApi
+
+test :: ()
+test = foo'EqualFoo
+  where
+    foo'EqualFoo :: Foo' ~ Foo => ()
+    foo'EqualFoo = ()
+
+test' :: ()
+test' = blah
+  where
+    blah :: ExtractRespTypes Api ~ '[Foo, Bar] => ()
+    blah = ()
+
+storeOfOurApi = storeOfApi @Api
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"