mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
tidying up
This commit is contained in:
parent
f5a8869a1b
commit
ab9b72af87
2
Makefile
Normal file
2
Makefile
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
testwatch:
|
||||||
|
ghcid -c 'stack repl --test --ghc-options=-fobject-code' --allow-eval --restart="stack.yaml" --restart="package.yaml"
|
@ -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
|
||||||
|
|
||||||
|
@ -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
12
scripts/pre-commit.sh
Executable 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
|
@ -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
71
src/Roboservant.hs
Normal 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
|
@ -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.
|
||||||
|
49
test/Spec.hs
49
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 :: IO ()
|
||||||
main = putStrLn "Test suite not yet implemented"
|
main = putStrLn "Test suite not yet implemented"
|
||||||
|
Loading…
Reference in New Issue
Block a user