diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 2.1.0 +* GHC 8.0/8.2 compatible +* merge web-routing modules, `Network.Routing.XXX` changed to `Data.Apiary.Routing.XXX`. + # 2.0.2 * add json to send ToJson instances with auto 'application/json' content type. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 2.0.2 +version: 2.1.0 synopsis: Simple and type safe web framework that generate web API documentation. description: Simple and type safe web framework that can be automatically generate API documentation. @@ -47,7 +47,7 @@ license: MIT license-file: LICENSE author: HirotomoMoriwaki -maintainer: HirotomoMoriwaki +maintainer: HirotomoMoriwaki, 韩冬 Homepage: https://github.com/philopon/apiary Bug-reports: https://github.com/philopon/apiary/issues copyright: (c) 2014-2015 Hirotomo Moriwaki @@ -80,30 +80,36 @@ Data.Apiary.Document Data.Apiary.Document.Html + Data.Apiary.Routing + Data.Apiary.Routing.Dict + other-modules: Web.Apiary.TH Data.Apiary.SProxy Data.Apiary.Document.Internal Data.Apiary.Extension.Internal + Data.Apiary.Routing.Dict.Internal Control.Monad.Apiary.Internal Control.Monad.Apiary.Filter.Internal Control.Monad.Apiary.Action.Internal Control.Monad.Apiary.Filter.Internal.Capture.TH - build-depends: base >=4.6 && <4.9 - , template-haskell >=2.8 && <2.11 + build-depends: base >=4.7 && <5.0 + , template-haskell >=2.8 && <2.13 - , transformers >=0.2 && <0.5 - , transformers-base >=0.4 && <0.5 + , transformers >=0.2 && <0.6 + , transformers-base >=0.4 && <0.6 , mtl >=2.1 && <2.3 , monad-control >=0.3 && <1.1 , exceptions >=0.6 && <0.9 , resourcet >=0.4.6 && <1.2 + , ghc-prim + , primitive + , http-types >=0.8 && <0.10 , mime-types >=0.1 && <0.2 , text >=1.1 && <1.3 , bytestring >=0.10 && <0.11 - , bytestring-read >=0.2 && <0.4 , blaze-builder >=0.3 && <0.5 , blaze-html >=0.7 && <0.9 , blaze-markup >=0.6 && <0.8 @@ -115,15 +121,15 @@ , unordered-containers >=0.2 && <0.3 , hashable >=1.1 && <1.3 , time >=1.4 && <1.6 - , process >=1.2 && <1.3 + , process >=1.2 && <2.0 , unix-compat >=0.4 && <0.5 , http-date >=0.0 && <0.1 , wai >=3.0 && <3.3 , wai-extra >=3.0.15 && <3.1 , stringsearch >=0.3 && <0.4 - , web-routing >=0.6 && <0.7 - , types-compat >=0.1 && <0.2 + , bytestring-lexing >=0.5 && <0.6 + , hetero-dict >=0.1.1 && <0.1.2 hs-source-dirs: src ghc-options: -O2 -Wall @@ -135,7 +141,7 @@ other-modules: Application , Method type: exitcode-stdio-1.0 - build-depends: base >=4.6 && <4.9 + build-depends: base >=4.6 && <5.0 , mtl >=2.1 && <2.3 , tasty >=0.10 && <0.12 , tasty-hunit >=0.9 && <0.10 diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -122,7 +122,7 @@ import qualified Network.Wai.Parse as P import Network.Wai.Request (requestSizeCheck, RequestSizeException(..)) -import qualified Network.Routing.Dict as Dict +import qualified Data.Apiary.Routing.Dict as Dict import Data.Apiary.Param(Param, File(..)) import Data.Apiary.SProxy(SProxy(..)) import Data.Apiary.Document(Documents) diff --git a/src/Control/Monad/Apiary/Filter.hs b/src/Control/Monad/Apiary/Filter.hs --- a/src/Control/Monad/Apiary/Filter.hs +++ b/src/Control/Monad/Apiary/Filter.hs @@ -66,12 +66,12 @@ import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import Data.Monoid((<>)) -import Data.Proxy.Compat(Proxy(..)) -import GHC.TypeLits.Compat(KnownSymbol, Symbol, symbolVal) +import Data.Proxy(Proxy(..)) +import GHC.TypeLits(KnownSymbol, Symbol, symbolVal) import Data.Apiary.SProxy(SProxy(..)) -import Network.Routing.Dict(type ( f r >>= \(k, p) -> return $ Dict.add k p c -- | filter only(not modify arguments). -function_ :: Monad actM => (Doc -> Doc) -> (Wai.Request -> Bool) +function_ :: Monad actM => (Doc -> Doc) -> (Wai.Request -> Bool) -> Filter' exts actM m function_ d f = function d $ \c r -> if f r then Just c else Nothing diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs @@ -16,7 +16,7 @@ import Data.String(IsString(..)) import Data.List(isInfixOf) import Data.Apiary.SProxy(SProxy(..)) -import Data.Proxy.Compat(Proxy(..)) +import Data.Proxy(Proxy(..)) preCap :: String -> [String] preCap "" = [] @@ -41,7 +41,7 @@ (_:'$':b, "]") -> TH.lookupValueName b >>= maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(TH.varE n)|])) (_:b, "]") -> return (t, [|Just $(TH.stringE b)|]) - (_, _) -> fail "capture: syntax error." + (_, _) -> fail "capture: syntax error." mkCap :: [String] -> TH.ExpQ mkCap [] = [|id|] @@ -67,7 +67,7 @@ -- [capture|\/path|] -- first path == "path" -- [capture|\/int\/foo::Int|] -- first path == "int" && get 2nd path as Int. -- [capture|\/bar::Int\/baz::Double|] -- get first path as Int and get 2nd path as Double. --- [capture|/**baz|] -- feed greedy and get all path as [Text] (since 0.17.0). +-- [capture|/**baz|] -- feed greedy and get all path as [Text] (since 0.17.0). -- @ -- -- this QQ can convert pure function easily. @@ -78,7 +78,7 @@ -- @ -- capture :: QuasiQuoter -capture = QuasiQuoter +capture = QuasiQuoter { quoteExp = mkCap . preCap , quotePat = \_ -> error "No quotePat." , quoteType = \_ -> error "No quoteType." diff --git a/src/Control/Monad/Apiary/Internal.hs b/src/Control/Monad/Apiary/Internal.hs --- a/src/Control/Monad/Apiary/Internal.hs +++ b/src/Control/Monad/Apiary/Internal.hs @@ -55,7 +55,7 @@ , execActionT, hoistActionT, applyDict, rootPattern ) -import qualified Network.Routing as R +import qualified Data.Apiary.Routing as R import Data.Apiary.Method(Method, renderMethod) import Data.Apiary.Extension ( Has, MonadExts(..), getExt, noExtension ) import Data.Apiary.Extension.Internal(Initializer(..), allMiddleware, allMiddleware') diff --git a/src/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -62,12 +62,11 @@ import Data.Word(Word, Word8, Word16, Word32, Word64) #endif import Data.Maybe(isJust, catMaybes) -import Network.Routing.Dict(KV((:=)), type ( a -> Bool jsToBool = flip notElem jsFalse @@ -172,15 +172,14 @@ -------------------------------------------------------------------------------- -class Query a where +class Typeable a => Query a where -- | read query parameter. readQuery :: Maybe S.ByteString -- ^ value of query parameter. Nothing is key only parameter. -> Maybe a -- ^ Noting is fail. -- | pretty query parameter. queryRep :: proxy a -> QueryRep - queryRep = Strict . qTypeRep - qTypeRep :: proxy a -> TypeRep + queryRep = Strict . typeRep readBS :: (S.ByteString -> Maybe (a, S.ByteString)) -> S.ByteString -> Maybe a @@ -189,56 +188,50 @@ _ -> Nothing readBSInt :: Integral a => S.ByteString -> Maybe a -readBSInt = readBS (SL.signed SL.integral) +readBSInt = readBS (BSL.readSigned BSL.readDecimal) readBSWord :: Integral a => S.ByteString -> Maybe a -readBSWord = readBS SL.integral +readBSWord = readBS BSL.readDecimal readBSDouble :: S.ByteString -> Maybe Double -readBSDouble = readBS (SL.signed SL.double) +readBSDouble = readBS (BSF.readSigned BSF.readDecimal) -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0. instance Query Bool where readQuery (Just b) = Just $ jsToBool b readQuery Nothing = Just True - qTypeRep = typeRep -instance Query Int where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Int8 where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Int16 where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Int32 where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Int64 where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep -instance Query Integer where readQuery = maybe Nothing readBSInt; qTypeRep = typeRep +instance Query Int where readQuery = maybe Nothing readBSInt +instance Query Int8 where readQuery = maybe Nothing readBSInt +instance Query Int16 where readQuery = maybe Nothing readBSInt +instance Query Int32 where readQuery = maybe Nothing readBSInt +instance Query Int64 where readQuery = maybe Nothing readBSInt +instance Query Integer where readQuery = maybe Nothing readBSInt -instance Query Word where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep -instance Query Word8 where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep -instance Query Word16 where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep -instance Query Word32 where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep -instance Query Word64 where readQuery = maybe Nothing readBSWord; qTypeRep = typeRep +instance Query Word where readQuery = maybe Nothing readBSWord +instance Query Word8 where readQuery = maybe Nothing readBSWord +instance Query Word16 where readQuery = maybe Nothing readBSWord +instance Query Word32 where readQuery = maybe Nothing readBSWord +instance Query Word64 where readQuery = maybe Nothing readBSWord -instance Query Double where readQuery = maybe Nothing readBSDouble; qTypeRep = typeRep -instance Query Float where readQuery = maybe Nothing (fmap realToFrac . readBSDouble); qTypeRep = typeRep +instance Query Double where readQuery = maybe Nothing readBSDouble +instance Query Float where readQuery = maybe Nothing (fmap realToFrac . readBSDouble) instance Query T.Text where readQuery = fmap $ T.decodeUtf8With lenientDecode - qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query TL.Text where readQuery = fmap (TL.decodeUtf8With lenientDecode . L.fromStrict) - qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query S.ByteString where readQuery = id - qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query L.ByteString where readQuery = fmap L.fromStrict - qTypeRep _ = typeRep (Proxy :: Proxy Text) instance Query String where readQuery = fmap S.unpack - qTypeRep _ = typeRep (Proxy :: Proxy Text) -- | fuzzy date parse. three decimal split by 1 char. -- if year < 100 then + 2000. since 0.16.0. @@ -250,15 +243,14 @@ -- * 14.2.05 instance Query Day where readQuery = (>>= \s0 -> do - (y, s1) <- SL.integral s0 + (y, s1) <- BSL.readDecimal s0 when (S.null s1) Nothing - (m, s2) <- SL.integral $ S.tail s1 + (m, s2) <- BSL.readDecimal $ S.tail s1 when (S.null s2) Nothing - (d, s3) <- SL.integral $ S.tail s2 + (d, s3) <- BSL.readDecimal $ S.tail s2 unless (S.null s3) Nothing let y' = if y < 100 then 2000 + y else y return $ fromGregorian y' m d) - qTypeRep _ = typeRep (Proxy :: Proxy Day) -- | fuzzy date parse. three decimal split by 1 char. -- if year < 100 then + 2000. since 0.16.0. @@ -284,15 +276,12 @@ instance Query a => Query (Maybe a) where readQuery (Just a) = Just `fmap` readQuery (Just a) readQuery Nothing = Just Nothing - queryRep _ = Nullable $ qTypeRep (Proxy :: Proxy a) - qTypeRep _ = maybeCon `mkTyConApp` [qTypeRep (Proxy :: Proxy a)] - where maybeCon = typeRepTyCon $ typeOf (Nothing :: Maybe ()) + queryRep _ = Nullable $ typeRep (Proxy :: Proxy a) -- | always success. for check existence. instance Query () where readQuery _ = Just () queryRep _ = Check - qTypeRep _ = typeOf () pBool :: Proxy Bool pBool = Proxy diff --git a/src/Data/Apiary/Routing.hs b/src/Data/Apiary/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Routing.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE FlexibleContexts #-} -- for ghc-7.6 +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | >>> :set -XDataKinds -XPolyKinds -XOverloadedStrings +-- >>> data Proxy s = Proxy +-- >>> import Text.Read(readMaybe) +-- >>> import qualified Data.Text as T +-- +-- 1. create path +-- +-- >>> data Result = A | B T.Text | C | D Int | E T.Text deriving Show +-- +-- >>> let key = Proxy :: Proxy "key" +-- +-- >>> let a = root $ exact "foo" $ action Nothing (\_ -> Just A) +-- >>> let b = root $ exact "bar" $ fetch key Just $ action Nothing (\d -> Just . B $ D.get key d) +-- >>> let c = root $ exact "bar" $ any $ action (Just "GET") (\_ -> Just C) +-- >>> let d = root $ exact "bar" $ fetch key (\t -> readMaybe (T.unpack t) :: Maybe Int) $ action Nothing (\d -> Just . D $ D.get key d) +-- >>> let e = root $ exact "foo" $ fetch key Just $ exact "qux" $ action (Just "POST") (\d -> Just . E $ D.get key d) +-- >>> a +-- * /foo +-- >>> b +-- * /bar/:key +-- >>> c +-- GET /bar/** +-- >>> d +-- * /bar/:key +-- >>> e +-- POST /foo/:key/qux +-- +-- 2. create router +-- +-- >>> let r = e +| d +| a +| b +| c +| empty +-- +-- 3. execute router +-- +-- >>> let run = execute r +-- +-- >>> run "GET" ["foo"] +-- Just A +-- >>> run "GET" ["foo", "bar"] +-- Nothing +-- >>> run "GET" ["bar", "12"] +-- Just (D 12) +-- >>> run "GET" ["bar", "baz"] +-- Just (B "baz") +-- >>> run "GET" ["bar", "baz", "qux"] +-- Just C +-- >>> run "POST" ["bar", "baz", "qux"] +-- Nothing +-- >>> run "POST" ["foo", "bar", "baz"] +-- Nothing +-- >>> run "POST" ["foo", "bar", "qux"] +-- Just (E "bar") + +module Data.Apiary.Routing + ( Method + -- * Path + , Path + , showPath, getMethod + , root + -- ** children + , exact + -- ** action + , action + -- ** get parameter + , Raw + , raw + , fetch + , any + , rest + + -- * Router + , Router + , empty + , insert, (+|) + + -- * execute + , execute + + -- * reexport + -- | 'Store', ' [T.Text] -> m (D.Store d', [T.Text])) + -> !(Router d' m a) + -> !(Params d m a) -> Params d m a + PNil :: Params d m a + +-- | routing path +data Path d m a where + Exact :: !T.Text -> !(Path d m a) -> Path d m a + + Param :: !String -> (D.Store d -> [T.Text] -> m (D.Store d', [T.Text])) + -> !(Path d' m a) -> Path d m a + + Action :: !(Maybe Method) + -> (D.Dict d -> m a) -> Path d m a + +-- | root +-- +-- @ +-- root == id +-- @ +root :: Path '[] m a -> Path '[] m a +root = id +{-# INLINABLE root #-} + +-- | exact matching path +exact :: T.Text -> Path d m a -> Path d m a +exact = Exact +{-# INLINABLE exact #-} + +type Raw m d d' + = D.Store d -- ^ input dictionary + -> [T.Text] -- ^ input path information + -> m (D.Store d', [T.Text]) -- ^ output dictionary and path information + +-- | raw get parameter function +-- +-- if you want matching exact path, use 'exact' for performance +raw :: String -- ^ pretty print + -> Raw m d d' + -> Path d' m a -> Path d m a +raw = Param +{-# INLINABLE raw #-} + +-- ^ get one directory as parameter. +fetch :: (MonadPlus m, KnownSymbol k, k D. proxy k -- ^ dictionary key + -> (T.Text -> Maybe v) -- ^ reading function + -> Path (k 'D.:= v ': d) m a -> Path d m a +fetch p f = Param (':' : symbolVal p) go + where + go _ [] = mzero + go d (t:ts) = case f t of + Nothing -> mzero + Just v -> return (D.add p v d, ts) +{-# INLINABLE fetch #-} + +-- | drop any pathes +any :: Monad m => Path d m a -> Path d m a +any = Param "**" go + where + go d _ = return (d, []) +{-# INLINABLE any #-} + +-- | take any pathes as [Text] +rest :: (KnownSymbol k, Monad m, k D. proxy k -- ^ dictionary key + -> Path (k 'D.:= [T.Text] ': d) m a -> Path d m a +rest k = Param (':': symbolVal k ++ "**") go + where + go d r = return (D.add k r d, []) +{-# INLINABLE rest #-} + +-- | action +action :: Maybe Method -- ^ if Nothing, any method allowed + -> (D.Dict d -> m a) -- ^ action when route matching + -> Path d m a +action = Action +{-# INLINABLE action #-} + +instance Show (Path d m a) where + show p = maybe "*" SC.unpack (getMethod p) ++ ' ': showPath p + +-- | show path. since v0.6.0. +showPath :: Path d m a -> String +showPath = go id + where + go :: (String -> String) -> Path d m a -> String + go s (Exact t ps) = go (s . (++) ('/' : T.unpack t)) ps + go s (Param l _ ps) = go (s . (++) ('/' : l)) ps + go s (Action _ _) = s [] + +-- | get method. since v0.6.0. +getMethod :: Path d m a -> Maybe Method +getMethod = go + where + go :: Path d m a -> Maybe Method + go (Action m _) = m + go (Exact _ ps) = go ps + go (Param _ _ ps) = go ps + +-- | router +data Router d m a where + Router :: + { params :: !(Params d m a) + , children :: !(H.HashMap T.Text (Router d m a)) + , methods :: !(H.HashMap Method (D.Dict d -> m a)) + , anyMethod :: D.Dict d -> m a + } -> Router d m a + +emptyRouter :: MonadPlus m => Router d m a +emptyRouter = Router { params = PNil + , children = H.empty + , methods = H.empty + , anyMethod = const mzero + } +{-# INLINABLE emptyRouter #-} + +-- | empty router +empty :: MonadPlus m => Router '[] m a +empty = emptyRouter +{-# INLINABLE empty #-} + +insert' :: MonadPlus m => Path d m a -> Router d m a -> Router d m a +insert' (Exact p n) r = + let c = H.lookupDefault emptyRouter p (children r) + in r { children = H.insert p (insert' n c) (children r) } + +insert' (Param _ f n) Router{..} = Router + { params = PCons f (insert' n emptyRouter) params + , children = children + , methods = methods + , anyMethod = anyMethod + } + +insert' (Action (Just m) n) r = + let c = case H.lookup m (methods r) of + Nothing -> \d -> n d + Just p -> \d -> p d `mplus` n d + in r { methods = H.insert m c (methods r) } + +insert' (Action Nothing n) r = + r { anyMethod = \d -> anyMethod r d `mplus` n d } +{-# INLINABLE insert' #-} + +-- | insert path to router +insert :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a +insert = insert' +{-# INLINABLE insert #-} + +-- | infix version of `insert` +(+|) :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a +(+|) = insert +{-# INLINABLE (+|) #-} + +infixr `insert` +infixr +| + +-- | execute router +execute :: MonadPlus m => Router '[] m a -> Method -> [T.Text] -> m a +execute = {-# SCC execute #-} execute' D.emptyStore +{-# INLINABLE execute #-} + +execute' :: MonadPlus m => D.Store d -> Router d m a -> Method -> [T.Text] -> m a +execute' d Router{params, methods, anyMethod} m [] = {-# SCC execute' #-} fetching next d m [] params + where + next = case H.lookup m methods of + Nothing -> anyMethod (D.mkDict d) + Just f -> f (D.mkDict d) + +execute' d Router{params, children} m pps@(p:ps) = {-# SCC execute' #-} case H.lookup p children of + Nothing -> next + Just c -> execute' d c m ps `mplus` next + where + next = fetching mzero d m pps params +{-# INLINABLE execute' #-} + +fetching :: MonadPlus m => m a -> D.Store d -> Method -> [T.Text] -> Params d m a -> m a +fetching next d m pps = {-# SCC fetching #-} loop + where + loop PNil = next + loop (PCons f r o) = + do (d', pps') <- f d pps + execute' d' r m pps' + `mplus` loop o +{-# INLINABLE fetching #-} diff --git a/src/Data/Apiary/Routing/Dict.hs b/src/Data/Apiary/Routing/Dict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Routing/Dict.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module Data.Apiary.Routing.Dict + ( -- * store + Store + , emptyStore + , type ( Members ["foo" := Int, "bar" := Double] prms == (Member "foo" Int prms, Member "bar" Double prms) +-- +type family Members (kvs :: [KV *]) (prms :: [KV *]) :: Constraint +type instance Members '[] prms = () +type instance Members (k ':= v ': kvs) prms = (Member k v prms, Members kvs prms) diff --git a/src/Data/Apiary/Routing/Dict/Internal.hs b/src/Data/Apiary/Routing/Dict/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Apiary/Routing/Dict/Internal.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} -- for ghc-7.6 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif + +module Data.Apiary.Routing.Dict.Internal + ( Dict, Store + , ShowDict + , KV(..) + , emptyStore + , emptyDict + , type ( Any +unsafeToAny = unsafeCoerce +{-# INLINABLE unsafeToAny #-} + +unsafeFromAny :: Any -> a +unsafeFromAny = unsafeCoerce +{-# INLINABLE unsafeFromAny #-} + +-- | (kind) key-value pair +data KV v = Symbol := v + +-- | data store to construct dictionary. +-- +-- `add` and `mkDict` operation only allowed. +data KVList (kvs :: [KV *]) where + Cons :: v -> KVList kvs -> KVList (k ':= v ': kvs) + Empty :: KVList '[] + +instance ShowDict kvs => Show (Store kvs) where + show d = "Store {" ++ + (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 (mkDict d)) + ++ "}" + +data Store kvs = Store + { storeSize :: {-# UNPACK #-} !Int + , storeBody :: KVList kvs + } + +emptyStore :: Store '[] +emptyStore = Store 0 Empty +{-# INLINABLE emptyStore #-} + +emptyDict :: Dict '[] +emptyDict = mkDict emptyStore +{-# INLINABLE emptyDict #-} + +-- | (kind) pretty print type error of 'add'. +-- +-- @ +-- > add (Proxy :: Proxy "a") 12 $ add (Proxy :: Proxy "a") "a" emptyStore +-- Couldn't match type ‘'Dictionary’ with ‘'AlreadyHasKey "a"’ +-- @ + +data AddResult + = AlreadyHasKey Symbol + | Dictionary + +#if __GLASGOW_HASKELL__ > 707 +type family HasKey (k :: Symbol) (kvs :: [KV *]) :: AddResult where + HasKey k '[] = 'AlreadyHasKey k + HasKey k (k ':= v ': kvs) = 'Dictionary + HasKey k (k' ':= v ': kvs) = HasKey k kvs +#else +type family HasKey (k :: Symbol) (kvs :: [KV *]) :: AddResult +type instance HasKey k kvs = 'AlreadyHasKey k +#endif + +-- | 'not elem key' constraint(ghc >= 7.8) +type k >> let a = add (Proxy :: Proxy "foo") (12 :: Int) emptyStore +-- >>> a +-- Store {foo = 12 :: Int} +-- +-- >>> add (Proxy :: Proxy "bar") "baz" a +-- Store {bar = "baz" :: [Char], foo = 12 :: Int} +add :: (k proxy k -> v -> Store kvs -> Store (k ':= v ': kvs) +add _ v (Store l c) = Store (l + 1) (Cons v c) +{-# INLINABLE add #-} + +-- | heterogeneous dictionary +-- +-- 'get' operation only allowed. +newtype Dict (kvs :: [KV *]) = Dict (P.Array Any) + +class ShowDict (kvs :: [KV *]) where + showDict :: Int -> Dict kvs -> [(String, String, TypeRep)] + +instance ShowDict '[] where + showDict _ _ = [] + +instance (KnownSymbol k, Typeable v, Show v, ShowDict kvs) => ShowDict (k ':= v ': kvs) where + showDict i (Dict t) = + (symbolVal (Proxy :: Proxy k), show (unsafeFromAny $ P.indexArray t i :: v), typeOf (undefined :: v)): + showDict (i + 1) (unsafeCoerce $ Dict t :: Dict kvs) + +instance ShowDict kvs => Show (Dict kvs) where + show d = "Dict {" ++ + (intercalate ", " . map (\(k, v, t) -> k ++ " = " ++ v ++ " :: " ++ show t) $ showDict 0 d) + ++ "}" + +mkDict' :: forall s kvs. Store kvs -> ST s (Dict kvs) +mkDict' store = do + ary <- P.newArray (storeSize store) undefined + go ary + Dict `fmap` P.unsafeFreezeArray ary + where + go :: P.MutableArray (P.PrimState (ST s)) Any -> ST s () + go array = loop 0 (storeBody store) + where + loop :: Int -> KVList kvs' -> ST s () + loop !i (Cons v ss) = do + P.writeArray array i (unsafeToAny v) + loop (i + 1) ss + loop _ Empty = return () +{-# INLINABLE mkDict' #-} + +-- | O(n) convert "Store" to "Dictionary". +mkDict :: Store kvs -> Dict kvs +mkDict store = runST $ mkDict' store +{-# INLINABLE mkDict #-} + +-- | O(1) (>= ghc-7.8), O(n) (< ghc-7.8) get key from dictionary +-- +-- >>> let d = mkDict $ add (Proxy :: Proxy "foo") 12 $ add (Proxy :: Proxy "bar") "baz" emptyStore +-- >>> get (Proxy :: Proxy "foo") d +-- 12 +-- >>> get (Proxy :: Proxy "bar") d +-- "baz" +get :: Member k v kvs => proxy k -> Dict kvs -> v + +-- | (kind) pretty print type error of 'get' +-- +-- used only >= ghc-7.8 +-- +-- @ +-- > get (Proxy :: Proxy "b") (mkDict $ add (Proxy :: Proxy "a") "a" emptyStore) +-- Couldn't match type ‘'Key "b"’ with ‘'NotInDicrionary i’ +-- @ +data GetResult + = NotInDicrionary Nat + | Key Symbol + +#if __GLASGOW_HASKELL__ > 707 + +type family Ix' (i :: Nat) (k :: Symbol) (kvs :: [KV *]) :: GetResult where + Ix' i k '[] = 'Key k + Ix' i k (k ':= v ': kvs) = 'NotInDicrionary i + Ix' i k (k' ':= v ': kvs) = Ix' (i + 1) k kvs + +type Ix k kvs = Ix' 0 k kvs + +type Index = 'NotInDicrionary + +getImpl :: forall i proxy k kvs v. (Index i ~ Ix k kvs, KnownNat i) => proxy (k :: Symbol) -> Dict kvs -> v +getImpl _ (Dict d) = unsafeFromAny $ d `P.indexArray` fromIntegral (natVal (Proxy :: Proxy i)) +{-# INLINABLE getImpl #-} + +class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where + get' :: proxy k -> Dict kvs -> v + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} Member k v (k ':= v ': kvs) where +#else +instance Member k v (k ':= v ': kvs) where +#endif + get' = getImpl + {-# INLINE get' #-} + +instance (Member k v kvs, Index i ~ Ix k (k' ':= v' ': kvs), KnownNat i) => Member k v (k' ':= v' ': kvs) where + get' = getImpl + {-# INLINE get' #-} + +get = get' +#else +class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where + get' :: Int -> proxy k -> Dict kvs -> v + +instance Member k v (k ':= v ': kvs) where + get' !i _ (Dict d) = unsafeFromAny $ d `P.indexArray` i + {-# INLINE get' #-} + +instance Member k v kvs => Member k v (k' ':= v' ': kvs) where + get' !i k d = get' (i + 1) k (unsafeCoerce d :: Dict kvs) + {-# INLINE get' #-} + +get = get' 0 +#endif diff --git a/src/Data/Apiary/SProxy.hs b/src/Data/Apiary/SProxy.hs --- a/src/Data/Apiary/SProxy.hs +++ b/src/Data/Apiary/SProxy.hs @@ -3,6 +3,6 @@ module Data.Apiary.SProxy(SProxy(..)) where -import GHC.TypeLits.Compat(Symbol) +import GHC.TypeLits(Symbol) data SProxy (k :: Symbol) = SProxy diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -12,7 +12,7 @@ -- | Has, MonadHas, Extensions, Initializer, Initializer', (+>), noExtension , module Data.Apiary.Extension -- | Member, Members, NotMember, Elem((:=)) - , module Network.Routing.Dict + , module Data.Apiary.Routing.Dict , key -- | hiding mkStatus @@ -98,7 +98,7 @@ import Data.Apiary.Method(Method(..)) import Data.Apiary.Extension(Has, MonadExts(..), getExt, Extensions, Initializer, Initializer', (+>), noExtension) -import Network.Routing.Dict (Members, type () ) -import Data.Proxy.Compat(Proxy(..)) +import Data.Proxy(Proxy(..)) -data Heroku = Heroku +data Heroku = Heroku { herokuEnv :: IORef (Maybe (H.HashMap T.Text T.Text)) , herokuConfig :: HerokuConfig }