{-# LANGUAGE
    GADTs
  , PolyKinds
  , TypeFamilies
  , BangPatterns
  , TypeOperators
  , TupleSections
  , DoAndIfThenElse
  , ConstraintKinds
  , FlexibleContexts
  , OverloadedStrings
  , ScopedTypeVariables
  , NamedFieldPuns
  #-}

{- |
Module      : Web.Routes.Nested
Copyright   : (c) 2015, 2016, 2017, 2018 Athan Clark

License     : BSD-style
Maintainer  : athan.clark@gmail.com
Stability   : experimental
Portability : GHC

This module exports most of what you'll need for sophisticated routing -
all the tools from <https://hackage.haskell.org/package/wai-middleware-verbs wai-middleware-verbs>
(routing for the incoming HTTP method) and
<https://hackage.haskell.org/package/wai-middleware-content-type wai-middleware-content-type>
(routing for the incoming Accept header, and implied file extension),
<https://hackage.haskell.org/package/wai WAI> itself, and
<https://hackage.haskell.org/package/wai-transformers wai-transformers> - some simple
type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us
to embed monad transformer stacks for our applications.

To match a route, you have a few options - you can match against a string literal,
a regular expression (via <https://hackage.haskell.org/package/regex-compat regex-compat>),
or an <https://hackage.haskell.org/package/attoparsec attoparsec> parser. This list
will most likely grow in the future, depending on demand.

There is also support for embedding security layers in your routes, in the same
nested manner. By "tagging" a set of routes with an authorization role (with @auth@),
you populate a list of roles breached during any request. The function argument to
'routeAuth' guards a Request to pass or fail at the high level, while 'auth' lets
you create your authorization boundaries on a case-by-case basis. Both allow
you to tap into the monad transformer stack for logging, STRefs, database queries,
etc.
-}


module Web.Routes.Nested
  ( -- * Router Construction
    match
  , matchHere
  , matchAny
  , matchGroup
  , auth
  , -- * Routing Middleware
    route
  , routeAuth
  , -- ** Precise Route Extraction
    extractMatch
  , extractMatchAny
  , extractAuthSym
  , extractAuth
  , extractNearestVia
  , -- * Metadata
    SecurityToken (..)
  , AuthScope (..)
  , Match
  , MatchGroup
  , -- * Re-Exports
    module Web.Routes.Nested.Match
  , module Web.Routes.Nested.Types
  , module Network.Wai.Middleware.Verbs
  , module Network.Wai.Middleware.ContentType
  ) where

import           Web.Routes.Nested.Match            (UrlChunks, origin_)
import           Web.Routes.Nested.Match
import           Web.Routes.Nested.Types            (RouterT, execRouterT, Tries (..), ExtrudeSoundly)
import           Web.Routes.Nested.Types
import           Network.Wai                        (Request, pathInfo)
import           Network.Wai.Trans                  (MiddlewareT)
import           Network.Wai.Middleware.Verbs
import           Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData)

import           Data.Trie.Pred.Base                (RootedPredTrie (..), PredTrie (..))
import           Data.Trie.Pred.Base.Step           (PredStep (..), Pred (..))
import qualified Data.Trie.Pred.Interface           as Interface
import           Data.Trie.Pred.Interface.Types     (Singleton (..), Extrude (..), CatMaybes)
import           Data.Trie.HashMap                  (HashMapStep (..), HashMapChildren (..))
import           Data.List.NonEmpty                 (NonEmpty (..), fromList)
import qualified Data.Text                          as T
import           Data.Hashable                      (Hashable)
import qualified Data.HashMap.Strict                as HM
import           Data.Monoid                        ((<>), First (..))
import           Data.Function.Poly                 (ArityTypeListIso)
import           Data.Bifunctor                     (bimap)

import qualified Control.Monad.State                as S
import           Control.Monad.Catch                (MonadThrow)
import           Control.Monad.Trans                (MonadTrans (..))
import           Control.Monad.IO.Class             (MonadIO (..))
import           Control.Arrow                      (first)
import           Control.Monad.ST                   (stToIO)


-- | The constraints necessary for 'match'.
type Match xs' xs childContent resultContent =
  ( xs' ~ CatMaybes xs
  , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent)
  , ArityTypeListIso childContent xs' resultContent
  )


-- | The constraints necessary for 'matchGroup'.
type MatchGroup xs' xs childContent resultContent childSec resultSec =
  ( ExtrudeSoundly xs' xs childContent resultContent
  , ExtrudeSoundly xs' xs childSec     resultSec
  )


-- | Embed a 'Network.Wai.Trans.MiddlewareT' into a set of routes via a matching string. You should
--   expect the match to create /arity/ in your handler - the @childContent@ variable.
--   The arity of @childContent@ may grow or shrink, depending on the heterogeneous
--   list created from the list of parsers, regular expressions, or arbitrary predicates
--   /in the order written/ - so something like:
--
--   > match (p_ "double-parser" double </> o_)
--   >   handler
--
--   ...then @handler@ /must/ have arity @Double ->@. If this
--   route was at the top level, then the total arity __must__ be @Double -> MiddlewareT m@.
--
--   Generally, if the routes you are building get grouped
--   by a predicate with 'matchGroup',
--   then we would need another level of arity /before/ the @Double@.
match :: Monad m
      => Match xs' xs childContent resultContent
      => UrlChunks xs -- ^ Predicative path to match against
      -> childContent -- ^ The response to send
      -> RouterT resultContent sec m ()
match :: forall (m :: * -> *) (xs' :: [*]) (xs :: [Maybe (*)]) childContent
       resultContent sec.
(Monad m, Match xs' xs childContent resultContent) =>
UrlChunks xs -> childContent -> RouterT resultContent sec m ()
match !UrlChunks xs
ts !childContent
vl =
  forall w (m :: * -> *). (Monoid w, MonadState w m) => w -> m ()
tell' forall a b. (a -> b) -> a -> b
$ forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries (forall chunks a trie.
Singleton chunks a trie =>
chunks -> a -> trie
singleton UrlChunks xs
ts childContent
vl)
                forall a. Monoid a => a
mempty
                forall a. Monoid a => a
mempty


{-# INLINEABLE match #-}

-- | Create a handle for the /current/ route - an alias for @\h -> match o_ h@.
matchHere :: Monad m
          => childContent -- ^ The response to send
          -> RouterT childContent sec m ()
matchHere :: forall (m :: * -> *) childContent sec.
Monad m =>
childContent -> RouterT childContent sec m ()
matchHere = forall (m :: * -> *) (xs' :: [*]) (xs :: [Maybe (*)]) childContent
       resultContent sec.
(Monad m, Match xs' xs childContent resultContent) =>
UrlChunks xs -> childContent -> RouterT resultContent sec m ()
match UrlChunks '[]
origin_

{-# INLINEABLE matchHere #-}


-- | Match against any route, as a last resort against all failing matches -
--   use this for a catch-all at some level in their routes, something
--   like a @not-found 404@ page is useful.
matchAny :: Monad m
         => childContent -- ^ The response to send
         -> RouterT childContent sec m ()
matchAny :: forall (m :: * -> *) childContent sec.
Monad m =>
childContent -> RouterT childContent sec m ()
matchAny !childContent
vl =
  forall w (m :: * -> *). (Monoid w, MonadState w m) => w -> m ()
tell' forall a b. (a -> b) -> a -> b
$ forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries forall a. Monoid a => a
mempty
                (forall chunks a trie.
Singleton chunks a trie =>
chunks -> a -> trie
singleton UrlChunks '[]
origin_ childContent
vl)
                forall a. Monoid a => a
mempty


{-# INLINEABLE matchAny #-}


-- | Prepends a common route to an existing set of routes. You should note that
--   doing this with a parser or regular expression will necessitate the existing
--   arity in the handlers before the progam can compile.
matchGroup :: Monad m
           => MatchGroup xs' xs childContent resultContent childSec resultSec
           => UrlChunks xs -- ^ Predicative path to match against
           -> RouterT childContent  childSec  m () -- ^ Child routes to nest
           -> RouterT resultContent resultSec m ()
matchGroup :: forall (m :: * -> *) (xs' :: [*]) (xs :: [Maybe (*)]) childContent
       resultContent childSec resultSec.
(Monad m,
 MatchGroup xs' xs childContent resultContent childSec resultSec) =>
UrlChunks xs
-> RouterT childContent childSec m ()
-> RouterT resultContent resultSec m ()
matchGroup !UrlChunks xs
ts RouterT childContent childSec m ()
cs = do
  (Tries RootedPredTrie Text childContent
trieContent' RootedPredTrie Text childContent
trieNotFound RootedPredTrie Text childSec
trieSec) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT childContent childSec m ()
cs
  forall w (m :: * -> *). (Monoid w, MonadState w m) => w -> m ()
tell' forall a b. (a -> b) -> a -> b
$ forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries (forall chunks start result.
Extrude chunks start result =>
chunks -> start -> result
extrude UrlChunks xs
ts RootedPredTrie Text childContent
trieContent')
                (forall chunks start result.
Extrude chunks start result =>
chunks -> start -> result
extrude UrlChunks xs
ts RootedPredTrie Text childContent
trieNotFound)
                (forall chunks start result.
Extrude chunks start result =>
chunks -> start -> result
extrude UrlChunks xs
ts RootedPredTrie Text childSec
trieSec)


{-# INLINEABLE matchGroup #-}

-- | Use a custom security token type and an 'AuthScope' to define
--   /where/ and /what kind/ of security should take place.
data SecurityToken s = SecurityToken
  { forall s. SecurityToken s -> s
securityToken :: !s
  , forall s. SecurityToken s -> AuthScope
securityScope :: !AuthScope
  } deriving (Int -> SecurityToken s -> ShowS
forall s. Show s => Int -> SecurityToken s -> ShowS
forall s. Show s => [SecurityToken s] -> ShowS
forall s. Show s => SecurityToken s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SecurityToken s] -> ShowS
$cshowList :: forall s. Show s => [SecurityToken s] -> ShowS
show :: SecurityToken s -> String
$cshow :: forall s. Show s => SecurityToken s -> String
showsPrec :: Int -> SecurityToken s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> SecurityToken s -> ShowS
Show)

-- | Designate the scope of security to the set of routes - either only the adjacent
-- routes, or the adjacent /and/ the parent container node (root node if not
-- declared).
data AuthScope
  = ProtectHere
  | DontProtectHere
  deriving (Int -> AuthScope -> ShowS
[AuthScope] -> ShowS
AuthScope -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthScope] -> ShowS
$cshowList :: [AuthScope] -> ShowS
show :: AuthScope -> String
$cshow :: AuthScope -> String
showsPrec :: Int -> AuthScope -> ShowS
$cshowsPrec :: Int -> AuthScope -> ShowS
Show, AuthScope -> AuthScope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthScope -> AuthScope -> Bool
$c/= :: AuthScope -> AuthScope -> Bool
== :: AuthScope -> AuthScope -> Bool
$c== :: AuthScope -> AuthScope -> Bool
Eq)

-- | Sets the security role and error handler for a set of routes, optionally
-- including its parent route.
auth :: Monad m
     => sec -- ^ Your security token
     -> AuthScope
     -> RouterT content (SecurityToken sec) m ()
auth :: forall (m :: * -> *) sec content.
Monad m =>
sec -> AuthScope -> RouterT content (SecurityToken sec) m ()
auth !sec
token !AuthScope
scope =
  forall w (m :: * -> *). (Monoid w, MonadState w m) => w -> m ()
tell'  (forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries forall a. Monoid a => a
mempty
                forall a. Monoid a => a
mempty
                (forall chunks a trie.
Singleton chunks a trie =>
chunks -> a -> trie
singleton UrlChunks '[]
origin_ (forall s. s -> AuthScope -> SecurityToken s
SecurityToken sec
token AuthScope
scope)))


{-# INLINEABLE auth #-}


-- * Routing ---------------------------------------

-- | Use this function to run your 'RouterT' into a 'MiddlewareT';
--   making your router executable in WAI. Note that this only
--   responds with content, and doesn't protect your routes with
--   your calls to 'auth'; to protect routes, postcompose this
--   with 'routeAuth':
--
--   > route routes . routeAuth routes
route :: MonadIO m
      => RouterT (MiddlewareT m) sec m a -- ^ The Router
      -> MiddlewareT m
route :: forall (m :: * -> *) sec a.
MonadIO m =>
RouterT (MiddlewareT m) sec m a -> MiddlewareT m
route RouterT (MiddlewareT m) sec m a
hs ApplicationT m
app Request
req Response -> m ResponseReceived
resp = do
  let path :: [Text]
path = Request -> [Text]
pathInfo Request
req
  Maybe (MiddlewareT m)
mightMatch <- forall (m :: * -> *) r sec a.
MonadIO m =>
[Text] -> RouterT r sec m a -> m (Maybe r)
extractMatch [Text]
path RouterT (MiddlewareT m) sec m a
hs
  case Maybe (MiddlewareT m)
mightMatch of
    Maybe (MiddlewareT m)
Nothing -> do
      Maybe (MiddlewareT m)
mMatch <- forall (m :: * -> *) r sec a.
MonadIO m =>
[Text] -> RouterT r sec m a -> m (Maybe r)
extractMatchAny [Text]
path RouterT (MiddlewareT m) sec m a
hs
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (ApplicationT m
app Request
req Response -> m ResponseReceived
resp)
        (\MiddlewareT m
mid -> MiddlewareT m
mid ApplicationT m
app Request
req Response -> m ResponseReceived
resp)
        Maybe (MiddlewareT m)
mMatch
    Just MiddlewareT m
mid -> MiddlewareT m
mid ApplicationT m
app Request
req Response -> m ResponseReceived
resp


-- | Supply a method to decide whether or not to 'Control.Monad.Catch.throwM'
--   an exception based on the current 'Network.Wai.Middleware.Request' and
--   the /layers/ of 'auth' tokens passed in your router, turn your router
--   into a 'Control.Monad.guard' for middlewares, basically.
routeAuth :: MonadIO m
          => MonadThrow m
          => (Request -> [sec] -> m ()) -- ^ authorization method
          -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router
          -> MiddlewareT m
routeAuth :: forall (m :: * -> *) sec a.
(MonadIO m, MonadThrow m) =>
(Request -> [sec] -> m ())
-> RouterT (MiddlewareT m) (SecurityToken sec) m a -> MiddlewareT m
routeAuth Request -> [sec] -> m ()
authorize RouterT (MiddlewareT m) (SecurityToken sec) m a
hs ApplicationT m
app Request
req Response -> m ResponseReceived
resp = do
  forall (m :: * -> *) sec x a.
(MonadIO m, MonadThrow m) =>
(Request -> [sec] -> m ())
-> Request -> RouterT x (SecurityToken sec) m a -> m ()
extractAuth Request -> [sec] -> m ()
authorize Request
req RouterT (MiddlewareT m) (SecurityToken sec) m a
hs
  forall (m :: * -> *) sec a.
MonadIO m =>
RouterT (MiddlewareT m) sec m a -> MiddlewareT m
route RouterT (MiddlewareT m) (SecurityToken sec) m a
hs ApplicationT m
app Request
req Response -> m ResponseReceived
resp

-- * Extraction -------------------------------

-- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes.
extractMatch :: MonadIO m
             => [T.Text] -- ^ The path to match against
             -> RouterT r sec m a -- ^ The Router
             -> m (Maybe r)
extractMatch :: forall (m :: * -> *) r sec a.
MonadIO m =>
[Text] -> RouterT r sec m a -> m (Maybe r)
extractMatch [Text]
path !RouterT r sec m a
hs = do
  Tries{RootedPredTrie Text r
trieContent :: forall x s. Tries x s -> RootedPredTrie Text x
trieContent :: RootedPredTrie Text r
trieContent} <- forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT r sec m a
hs
  let mResult :: Maybe ([Text], r)
mResult = forall s a.
(Hashable s, Eq s) =>
(s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)
lookupWithLRPT Text -> Text
trimFileExt [Text]
path RootedPredTrie Text r
trieContent
  case Maybe ([Text], r)
mResult of
    Maybe ([Text], r)
Nothing ->
      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
path)
         Bool -> Bool -> Bool
&& Text -> Text
trimFileExt (forall a. [a] -> a
last [Text]
path) forall a. Eq a => a -> a -> Bool
== Text
"index"
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a.
(Eq k, Hashable k) =>
[k] -> RootedPredTrie k a -> Maybe a
Interface.lookup (forall a. [a] -> [a]
init [Text]
path) RootedPredTrie Text r
trieContent
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just ([Text]
_,r
r) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just r
r)

{-# INLINEABLE extractMatch #-}


-- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound.
extractMatchAny :: MonadIO m
                => [T.Text] -- ^ The path to match against
                -> RouterT r sec m a -- ^ The Router
                -> m (Maybe r)
extractMatchAny :: forall (m :: * -> *) r sec a.
MonadIO m =>
[Text] -> RouterT r sec m a -> m (Maybe r)
extractMatchAny [Text]
path = forall (m :: * -> *) r sec a.
MonadIO m =>
[Text]
-> (RouterT r sec m a -> m (RootedPredTrie Text r))
-> RouterT r sec m a
-> m (Maybe r)
extractNearestVia [Text]
path (\RouterT r sec m a
x -> forall x s. Tries x s -> RootedPredTrie Text x
trieCatchAll forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT r sec m a
x)

{-# INLINEABLE extractMatchAny #-}



-- | Find the security tokens / authorization roles affiliated with
--   a request for a set of routes.
extractAuthSym :: MonadIO m
               => [T.Text] -- ^ The path to match against
               -> RouterT x (SecurityToken sec) m a -- ^ The Router
               -> m [sec]
extractAuthSym :: forall (m :: * -> *) x sec a.
MonadIO m =>
[Text] -> RouterT x (SecurityToken sec) m a -> m [sec]
extractAuthSym [Text]
path RouterT x (SecurityToken sec) m a
hs = do
  Tries{RootedPredTrie Text (SecurityToken sec)
trieSecurity :: forall x s. Tries x s -> RootedPredTrie Text s
trieSecurity :: RootedPredTrie Text (SecurityToken sec)
trieSecurity} <- forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT x (SecurityToken sec) m a
hs
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ST RealWorld a -> IO a
stToIO forall a b. (a -> b) -> a -> b
$ do
    let results :: [([Text], SecurityToken sec, [Text])]
results = forall k a.
(Hashable k, Eq k) =>
[k] -> RootedPredTrie k a -> [([k], a, [k])]
Interface.matches [Text]
path RootedPredTrie Text (SecurityToken sec)
trieSecurity
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a} {a}. (a, SecurityToken a, [a]) -> [a] -> [a]
go [] [([Text], SecurityToken sec, [Text])]
results
  where
    go :: (a, SecurityToken a, [a]) -> [a] -> [a]
go (a
_,SecurityToken a
_ AuthScope
DontProtectHere,[]) [a]
ys = [a]
ys
    go (a
_,SecurityToken a
x AuthScope
_              ,[a]
_ ) [a]
ys = a
xforall a. a -> [a] -> [a]
:[a]
ys

{-# INLINEABLE extractAuthSym #-}

-- | Extracts only the security handling logic, and turns it into a guard.
extractAuth :: MonadIO m
            => MonadThrow m
            => (Request -> [sec] -> m ()) -- ^ authorization method
            -> Request
            -> RouterT x (SecurityToken sec) m a
            -> m ()
extractAuth :: forall (m :: * -> *) sec x a.
(MonadIO m, MonadThrow m) =>
(Request -> [sec] -> m ())
-> Request -> RouterT x (SecurityToken sec) m a -> m ()
extractAuth Request -> [sec] -> m ()
authorize Request
req RouterT x (SecurityToken sec) m a
hs = do
  [sec]
ss <- forall (m :: * -> *) x sec a.
MonadIO m =>
[Text] -> RouterT x (SecurityToken sec) m a -> m [sec]
extractAuthSym (Request -> [Text]
pathInfo Request
req) RouterT x (SecurityToken sec) m a
hs
  Request -> [sec] -> m ()
authorize Request
req [sec]
ss

{-# INLINEABLE extractAuth #-}


-- | Given a way to draw out a special-purpose trie from our route set, route
--   to the responses based on a /furthest-route-reached/ method, or like a
--   greatest-lower-bound.
extractNearestVia :: MonadIO m
                  => [T.Text] -- ^ The path to match against
                  -> (RouterT r sec m a -> m (RootedPredTrie T.Text r))
                  -> RouterT r sec m a
                  -> m (Maybe r)
extractNearestVia :: forall (m :: * -> *) r sec a.
MonadIO m =>
[Text]
-> (RouterT r sec m a -> m (RootedPredTrie Text r))
-> RouterT r sec m a
-> m (Maybe r)
extractNearestVia [Text]
path RouterT r sec m a -> m (RootedPredTrie Text r)
extr RouterT r sec m a
hs = do
  RootedPredTrie Text r
trie <- RouterT r sec m a -> m (RootedPredTrie Text r)
extr RouterT r sec m a
hs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {a} {b} {c}. (a, b, c) -> b
mid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a.
(Hashable k, Eq k) =>
[k] -> RootedPredTrie k a -> Maybe ([k], a, [k])
Interface.match [Text]
path RootedPredTrie Text r
trie)
  where
    mid :: (a, b, c) -> b
mid (a
_,b
r,c
_) = b
r

{-# INLINEABLE extractNearestVia #-}



-- * Pred-Trie related -----------------

-- | Removes @.txt@ from @foo.txt@
trimFileExt :: T.Text -> T.Text
trimFileExt :: Text -> Text
trimFileExt !Text
s =
  case Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
s of
    (Text
f,Text
e) | Text
f forall a. Eq a => a -> a -> Bool
/= Text
""
          Bool -> Bool -> Bool
&& Text
e forall a. Eq a => a -> a -> Bool
/= Text
""
          Bool -> Bool -> Bool
&& Text -> Int
T.length Text
f forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> Text -> Text
T.dropEnd Int
1 Text
f
    (Text, Text)
_ -> Text
s

{-# INLINEABLE trimFileExt #-}


-- | A quirky function for processing the last element of a lookup path, only
-- on /literal/ matches.
lookupWithLPT :: Hashable s
              => Eq s
              => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)
lookupWithLPT :: forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)
lookupWithLPT s -> s
f NonEmpty s
tss (PredTrie (HashMapStep HashMap s (HashMapChildren PredTrie s a)
ls) (PredStep HashMap s (Pred PredTrie s a)
ps)) =
  forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> First a
First (forall s a.
(Hashable s, Eq s) =>
(s -> s)
-> NonEmpty s
-> HashMap s (HashMapChildren PredTrie s a)
-> Maybe ([s], a)
goLit s -> s
f NonEmpty s
tss HashMap s (HashMapChildren PredTrie s a)
ls)
          forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> Pred PredTrie s a -> Maybe ([s], a)
goPred s -> s
f NonEmpty s
tss) HashMap s (Pred PredTrie s a)
ps

goLit :: Hashable s
      => Eq s
      => (s -> s)
      -> NonEmpty s
      -> HM.HashMap s (HashMapChildren PredTrie s a)
      -> Maybe ([s], a)
goLit :: forall s a.
(Hashable s, Eq s) =>
(s -> s)
-> NonEmpty s
-> HashMap s (HashMapChildren PredTrie s a)
-> Maybe ([s], a)
goLit s -> s
f (s
t:|[s]
ts) HashMap s (HashMapChildren PredTrie s a)
xs = do
  (HashMapChildren Maybe a
mx Maybe (PredTrie s a)
mxs) <- forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> First a
First (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup s
t HashMap s (HashMapChildren PredTrie s a)
xs)
                                      forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> First a
First (  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
ts
                                                  then forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (s -> s
f s
t) HashMap s (HashMapChildren PredTrie s a)
xs
                                                  else forall a. Maybe a
Nothing)
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
ts
  then ([s -> s
f s
t],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mx
  else forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (s
tforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)
lookupWithLPT s -> s
f (forall a. [a] -> NonEmpty a
fromList [s]
ts) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (PredTrie s a)
mxs)

goPred :: Hashable s
       => Eq s
       => (s -> s)
       -> NonEmpty s
       -> Pred PredTrie s a
       -> Maybe ([s], a)
goPred :: forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> Pred PredTrie s a -> Maybe ([s], a)
goPred s -> s
f (s
t:|[s]
ts) (Pred s -> Maybe r
predicate Maybe (r -> a)
mx PredTrie s (r -> a)
xs) = do
  r
d <- s -> Maybe r
predicate s
t
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
ts
  then (([s
t],) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ r
d)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (r -> a)
mx
  else forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (s
tforall a. a -> [a] -> [a]
:) (forall a b. (a -> b) -> a -> b
$ r
d) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)
lookupWithLPT s -> s
f (forall a. [a] -> NonEmpty a
fromList [s]
ts) PredTrie s (r -> a)
xs



{-# INLINEABLE lookupWithLPT #-}


lookupWithLRPT :: Hashable s
               => Eq s
               => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)
lookupWithLRPT :: forall s a.
(Hashable s, Eq s) =>
(s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)
lookupWithLRPT s -> s
_ [] (RootedPredTrie Maybe a
mx PredTrie s a
_) = ([],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mx
lookupWithLRPT s -> s
f [s]
ts (RootedPredTrie Maybe a
_ PredTrie s a
xs) = forall s a.
(Hashable s, Eq s) =>
(s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)
lookupWithLPT s -> s
f (forall a. [a] -> NonEmpty a
fromList [s]
ts) PredTrie s a
xs



{-# INLINEABLE lookupWithLRPT #-}


tell' :: Monoid w => S.MonadState w m => w -> m ()
tell' :: forall w (m :: * -> *). (Monoid w, MonadState w m) => w -> m ()
tell' w
x = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify' (forall a. Semigroup a => a -> a -> a
<> w
x)

{-# INLINEABLE tell' #-}