diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ceb9832 --- /dev/null +++ b/Makefile @@ -0,0 +1,2 @@ +testwatch: + ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml" diff --git a/package.yaml b/package.yaml index 9a70c8d..1a41f8b 100644 --- a/package.yaml +++ b/package.yaml @@ -24,7 +24,8 @@ dependencies: - servant # - servant-server - servant-flatten - +# test deps +- hspec library: source-dirs: src diff --git a/roboservant.cabal b/roboservant.cabal index 205ed43..2bd027c 100644 --- a/roboservant.cabal +++ b/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 diff --git a/scripts/pre-commit.sh b/scripts/pre-commit.sh new file mode 100755 index 0000000..1854bb1 --- /dev/null +++ b/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 diff --git a/src/Lib.hs b/src/Lib.hs index 5be3928..f7616cb 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -103,4 +103,3 @@ main = pure () -- 'Baz -> whole value -- '(Key Bar) -> key2 -- '(Key Foo) -> key1 - diff --git a/src/Roboservant.hs b/src/Roboservant.hs new file mode 100644 index 0000000..b9e3aad --- /dev/null +++ b/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 diff --git a/stack.yaml b/stack.yaml index a3d7e72..bd6dc38 100644 --- a/stack.yaml +++ b/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. diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..d1cdfdf 100644 --- a/test/Spec.hs +++ b/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"