tidying up

This commit is contained in:
Mark Wotton 2020-06-06 10:24:56 -04:00
parent f5a8869a1b
commit ab9b72af87
8 changed files with 141 additions and 4 deletions

2
Makefile Normal file
View File

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

View File

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

View File

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

12
scripts/pre-commit.sh Executable file
View File

@ -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

View File

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

71
src/Roboservant.hs Normal file
View File

@ -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

View File

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

View File

@ -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 :: IO ()
main = putStrLn "Test suite not yet implemented" main = putStrLn "Test suite not yet implemented"