apiary 2.0.2 → 2.1.0

raw patch · 15 files changed

+646/−76 lines, 15 filesdep +bytestring-lexingdep +ghc-primdep +hetero-dictdep −bytestring-readdep −types-compatdep −web-routingdep ~basedep ~processdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring-lexing, ghc-prim, hetero-dict, primitive

Dependencies removed: bytestring-read, types-compat, web-routing

Dependency ranges changed: base, process, template-haskell, transformers, transformers-base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• apiary.cabal +17/−11
• src/Control/Monad/Apiary/Action/Internal.hs +1/−1
• src/Control/Monad/Apiary/Filter.hs +5/−5
• src/Control/Monad/Apiary/Filter/Capture.hs +5/−5
• src/Control/Monad/Apiary/Filter/Internal.hs +5/−5
• src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +4/−4
• src/Control/Monad/Apiary/Internal.hs +1/−1
• src/Data/Apiary/Param.hs +28/−39
• src/Data/Apiary/Routing.hs +306/−0
• src/Data/Apiary/Routing/Dict.hs +41/−0
• src/Data/Apiary/Routing/Dict/Internal.hs +224/−0
• src/Data/Apiary/SProxy.hs +1/−1
• src/Web/Apiary.hs +2/−2
• src/Web/Apiary/Heroku.hs +2/−2

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

@@ -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<philopon.dependence@gmail.com>-maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>, 韩冬<drkoster@qq.com> 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

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

@@ -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 (</), KV((:=)))-import qualified Network.Routing.Dict as Dict-import qualified Network.Routing as R+import Data.Apiary.Routing.Dict(type (</), KV((:=)))+import qualified Data.Apiary.Routing.Dict as Dict+import qualified Data.Apiary.Routing as R  import Data.Apiary.Param     ( ReqParam, StrategyRep(..), QueryRep(NoValue)

@@ -15,12 +15,12 @@ import Control.Monad.Apiary.Filter.Internal     (Doc(DocPath, DocFetch, DocAny, DocRest)) -import GHC.TypeLits.Compat(KnownSymbol, symbolVal)-import Data.Proxy.Compat(Proxy(..))+import GHC.TypeLits(KnownSymbol, symbolVal)+import Data.Proxy(Proxy(..)) import Data.Apiary.Param(Path, pathRep, readPathAs)-import Network.Routing.Dict(KV((:=)))-import qualified Network.Routing.Dict as Dict-import qualified Network.Routing as R+import Data.Apiary.Routing.Dict(KV((:=)))+import qualified Data.Apiary.Routing.Dict as Dict+import qualified Data.Apiary.Routing as R  import qualified Data.Text as T import Text.Blaze.Html(Html)

@@ -16,10 +16,10 @@ import Control.Monad.Apiary.Internal(Filter, Filter', focus) import Control.Monad.Apiary.Action(getRequest) -import GHC.TypeLits.Compat(KnownSymbol)-import Network.Routing.Dict(type (</), KV((:=)), Store)-import qualified Network.Routing.Dict as Dict-import qualified Network.Routing as R+import GHC.TypeLits(KnownSymbol)+import Data.Apiary.Routing.Dict(type (</), KV((:=)), Store)+import qualified Data.Apiary.Routing.Dict as Dict+import qualified Data.Apiary.Routing as R import Data.Apiary.Document.Internal(Doc(..))  -- | low level filter function.@@ -38,6 +38,6 @@ function' d f = function d $ \c r -> 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

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

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

@@ -62,12 +62,11 @@ import Data.Word(Word, Word8, Word16, Word32, Word64) #endif import Data.Maybe(isJust, catMaybes)-import Network.Routing.Dict(KV((:=)), type (</), Store)-import qualified Network.Routing.Dict as Dict-import Data.Typeable.Compat-    ( Typeable, mkTyConApp, typeRepTyCon, typeOf, TypeRep, typeRep, Proxy(..))+import Data.Apiary.Routing.Dict(KV((:=)), type (</), Store)+import qualified Data.Apiary.Routing.Dict as Dict+import Data.Typeable -import GHC.TypeLits.Compat(Symbol, KnownSymbol)+import GHC.TypeLits(Symbol, KnownSymbol)  import Data.String(IsString) import Data.Time.Calendar(Day, fromGregorian)@@ -81,7 +80,8 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Read as SL+import qualified Data.ByteString.Lex.Integral as BSL+import qualified Data.ByteString.Lex.Fractional as BSF  jsToBool :: (IsString a, Eq a) => 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

@@ -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', '</', 'add'+    --+    -- 'Dict', 'Member', 'get'+    --+    -- 'KV'((':=')), 'Members'+    , module Data.Apiary.Routing.Dict+    ) where++import Prelude hiding(any)+import Control.Monad(MonadPlus(..))++import GHC.TypeLits(KnownSymbol, symbolVal)+import qualified Data.Apiary.Routing.Dict.Internal as D+import qualified Data.Text as T+import qualified Data.HashMap.Strict as H+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as SC++import Data.Apiary.Routing.Dict+    ( Store+    , type (</)+    , add++    , Dict+    , Member+    , get++    , KV(..)++    , Members+    )++type Method = S.ByteString++data Params d m a where+    PCons :: !(D.Store d -> [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.</ 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.</ 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 #-}

@@ -0,0 +1,41 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++module Data.Apiary.Routing.Dict+    ( -- * store+      Store+    , emptyStore+    , type (</)+    , add+    , mkDict++      -- * dictionary+    , Dict+    , emptyDict+    , Member+    , get++      -- * types+    , ShowDict+    , KV(..)++      -- * convenient+    , Members++      -- * pretty print type errors+    , GetResult(..)+    , AddResult(..)+    ) where++import GHC.Exts(Constraint)+import Data.Apiary.Routing.Dict.Internal++-- | type family to constraint multi kvs.+--+-- > 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)

@@ -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 (</)+    , add+    , Member+    , get+    , mkDict+    , AddResult(..)+    , GetResult(..)+    ) where++import GHC.Exts(Any)++import Data.Proxy+import GHC.TypeLits+import Data.Typeable(typeOf, Typeable, TypeRep)+import Data.List(intercalate)+import Unsafe.Coerce+import qualified Control.Monad.Primitive as P+import qualified Data.Primitive.Array as P+import Control.Monad.ST (ST, runST)++unsafeToAny :: a -> 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 </ v = HasKey k v ~ 'AlreadyHasKey k++-- | O(1) add key value pair to dictionary.+--+-- >>> 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 </ kvs) => 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

@@ -3,6 +3,6 @@  module Data.Apiary.SProxy(SProxy(..)) where -import GHC.TypeLits.Compat(Symbol)+import GHC.TypeLits(Symbol)  data SProxy (k :: Symbol) = SProxy

@@ -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 (</), KV((:=)))+import Data.Apiary.Routing.Dict (Members, type (</), KV((:=)))  import Network.HTTP.Types.Status hiding (mkStatus) import Data.Default.Class(def)

@@ -42,9 +42,9 @@     ( Has, Extension, Extensions, getExtension, noExtension     , Initializer, Initializer', initializer', (+>)     )-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     }