-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE PolyKinds                  #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Router
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.Router" provides a type-safe, bidirectional client-side router.
-- A Haskell sum type represents your application's routes; the 'Router'
-- class encodes and decodes between that type and URL strings. The router
-- is used together with 'Miso.Subscription.History.uriSub' or
-- 'Miso.Subscription.History.routerSub' to react to browser navigation.
--
-- = Approach 1 — Generic deriving (recommended)
--
-- @
-- {-\# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies \#-}
-- import GHC.Generics (Generic)
-- import "Miso.Router"
--
-- data Route
--   = Index                                                    -- \"\/\"
--   | About                                                    -- \"\/about\"
--   | User (Capture \"id\" Int)                                 -- \"\/user\/42\"
--   | Search (QueryParam \"q\" 'Miso.String.MisoString')         -- \"\/search?q=foo\"
--   deriving stock (Show, Eq, Generic)
--   deriving anyclass 'Router'
-- @
--
-- Decoding:
--
-- @
-- 'toRoute' \"\/user\/42\"  -- Right (User (Capture 42))
-- 'toRoute' \"\/search?q=hello\" -- Right (Search (QueryParam (Just \"hello\")))
-- @
--
-- Encoding (type-safe links):
--
-- @
-- 'prettyRoute' (User (Capture 42))       -- \"\/user\/42\"
-- button_ [ 'href_' (User (Capture 42)) ] [ text \"Profile\" ]
-- @
--
-- = Approach 2 — Manual instance
--
-- @
-- data Route = Widget Int deriving (Show, Eq)
--
-- instance 'Router' Route where
--   routeParser = 'routes' [ Widget \<$\> ('path' \"widget\" *\> 'capture') ]
--   fromRoute (Widget n) = [ 'toPath' \"widget\", 'toCapture' n ]
-- @
--
-- = Generic naming rules
--
-- * __Constructor name__ becomes the lowercase path segment:
--   @About@ → @\/about@, @UserProfile@ → @\/user@ (first camel-case hump only).
-- * The special name __@Index@__ encodes the root path @\/@.
-- * The position of t'Capture' and t'Path' fields in the constructor
--   determines their order in the URL path. The position of
--   t'QueryParam' and t'QueryFlag' does not matter.
--
-- = URL types
--
-- [@'Capture' sym a@] dynamic path segment — @Capture 42@ → @\/42@
-- [@'Path' sym@] fixed path segment — @Path \"foo\"@ → @\/foo@
-- [@'QueryParam' sym a@] optional query key — @QueryParam (Just 1)@ → @?sym=1@
-- [@'QueryFlag' sym@] boolean query flag — @QueryFlag True@ → @?sym@
-- [@'Fragment' sym@] hash fragment — @Fragment@ → @#sym@
--
-- = Integration with history subscription
--
-- @
-- import "Miso.Subscription.History" ('Miso.Subscription.History.routerSub')
--
-- subs :: ['Miso.Effect.Sub' Action]
-- subs = [ 'Miso.Subscription.History.routerSub' RouteChanged ]
-- @
--
-- = See also
--
-- * "Miso.Subscription.History" — 'Miso.Subscription.History.uriSub', 'Miso.Subscription.History.routerSub', 'Miso.Subscription.History.pushURI'
-- * "Miso.Html.Property" — 'Miso.Html.Property.href_' (plain string version)
-----------------------------------------------------------------------------
module Miso.Router
  ( -- ** Classes
    Router (..)
  , RouteParser
  , GRouter (..)
    -- ** Types
  , Capture (..)
  , Path (..)
  , QueryParam (..)
  , QueryFlag (..)
  , Fragment (..)
  , Token (..)
  , URI (..)
    -- ** Errors
  , RoutingError (..)
    -- ** Functions
  , parseURI
  , prettyURI
  , prettyQueryString
    -- ** Manual Routing
  , runRouter
  , routes
    -- ** Construction
  , toQueryParam
  , toCapture
  , toPath
  , emptyURI
    -- ** Parser combinators
  , queryFlag
  , queryParam
  , capture
  , path
  , fragment
    -- ** Lexing
  , lexTokens
  , tokensToURI
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe
import           Data.Bifunctor (first)
import           Data.Functor
import           Data.Proxy
import qualified Data.Char as C
import           Data.String
import           Control.Applicative
import           Control.Monad
import           GHC.Generics
import           GHC.TypeLits
-----------------------------------------------------------------------------
import           Miso.Types hiding (model, fragment, fragment_)
import           Miso.JSON (FromJSON (..))
import           Miso.Util
import qualified Miso.Html.Property as P
import           Miso.Util.Parser hiding (NoParses)
import qualified Miso.Util.Lexer as L
import           Miso.Util.Lexer (Lexer)
import           Miso.String (ToMisoString, FromMisoString, fromMisoStringEither)
import qualified Miso.String as MS
-----------------------------------------------------------------------------
-- | Type used for representing capture variables
newtype Capture sym a = Capture a
  deriving stock (Capture sym a -> Capture sym a -> Bool
(Capture sym a -> Capture sym a -> Bool)
-> (Capture sym a -> Capture sym a -> Bool) -> Eq (Capture sym a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
$c== :: forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
== :: Capture sym a -> Capture sym a -> Bool
$c/= :: forall k (sym :: k) a.
Eq a =>
Capture sym a -> Capture sym a -> Bool
/= :: Capture sym a -> Capture sym a -> Bool
Eq, Int -> Capture sym a -> ShowS
[Capture sym a] -> ShowS
Capture sym a -> [Char]
(Int -> Capture sym a -> ShowS)
-> (Capture sym a -> [Char])
-> ([Capture sym a] -> ShowS)
-> Show (Capture sym a)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall k (sym :: k) a. Show a => Int -> Capture sym a -> ShowS
forall k (sym :: k) a. Show a => [Capture sym a] -> ShowS
forall k (sym :: k) a. Show a => Capture sym a -> [Char]
$cshowsPrec :: forall k (sym :: k) a. Show a => Int -> Capture sym a -> ShowS
showsPrec :: Int -> Capture sym a -> ShowS
$cshow :: forall k (sym :: k) a. Show a => Capture sym a -> [Char]
show :: Capture sym a -> [Char]
$cshowList :: forall k (sym :: k) a. Show a => [Capture sym a] -> ShowS
showList :: [Capture sym a] -> ShowS
Show)
  deriving newtype (Capture sym a -> Text
(Capture sym a -> Text) -> ToMisoString (Capture sym a)
forall str. (str -> Text) -> ToMisoString str
forall k (sym :: k) a. ToMisoString a => Capture sym a -> Text
$ctoMisoString :: forall k (sym :: k) a. ToMisoString a => Capture sym a -> Text
toMisoString :: Capture sym a -> Text
ToMisoString, Text -> Either [Char] (Capture sym a)
(Text -> Either [Char] (Capture sym a))
-> FromMisoString (Capture sym a)
forall t. (Text -> Either [Char] t) -> FromMisoString t
forall k (sym :: k) a.
FromMisoString a =>
Text -> Either [Char] (Capture sym a)
$cfromMisoStringEither :: forall k (sym :: k) a.
FromMisoString a =>
Text -> Either [Char] (Capture sym a)
fromMisoStringEither :: Text -> Either [Char] (Capture sym a)
FromMisoString)
-----------------------------------------------------------------------------
-- | Type used for representing URL paths
newtype Path (path :: Symbol) = Path MisoString
  deriving stock (Path path -> Path path -> Bool
(Path path -> Path path -> Bool)
-> (Path path -> Path path -> Bool) -> Eq (Path path)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol). Path path -> Path path -> Bool
$c== :: forall (path :: Symbol). Path path -> Path path -> Bool
== :: Path path -> Path path -> Bool
$c/= :: forall (path :: Symbol). Path path -> Path path -> Bool
/= :: Path path -> Path path -> Bool
Eq, Int -> Path path -> ShowS
[Path path] -> ShowS
Path path -> [Char]
(Int -> Path path -> ShowS)
-> (Path path -> [Char])
-> ([Path path] -> ShowS)
-> Show (Path path)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol). Int -> Path path -> ShowS
forall (path :: Symbol). [Path path] -> ShowS
forall (path :: Symbol). Path path -> [Char]
$cshowsPrec :: forall (path :: Symbol). Int -> Path path -> ShowS
showsPrec :: Int -> Path path -> ShowS
$cshow :: forall (path :: Symbol). Path path -> [Char]
show :: Path path -> [Char]
$cshowList :: forall (path :: Symbol). [Path path] -> ShowS
showList :: [Path path] -> ShowS
Show)
  deriving newtype (Path path -> Text
(Path path -> Text) -> ToMisoString (Path path)
forall str. (str -> Text) -> ToMisoString str
forall (path :: Symbol). Path path -> Text
$ctoMisoString :: forall (path :: Symbol). Path path -> Text
toMisoString :: Path path -> Text
ToMisoString, [Char] -> Path path
([Char] -> Path path) -> IsString (Path path)
forall a. ([Char] -> a) -> IsString a
forall (path :: Symbol). [Char] -> Path path
$cfromString :: forall (path :: Symbol). [Char] -> Path path
fromString :: [Char] -> Path path
IsString)
-----------------------------------------------------------------------------
-- | Type used for representing query flags
newtype QueryFlag (path :: Symbol) = QueryFlag Bool
  deriving stock (QueryFlag path -> QueryFlag path -> Bool
(QueryFlag path -> QueryFlag path -> Bool)
-> (QueryFlag path -> QueryFlag path -> Bool)
-> Eq (QueryFlag path)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
$c== :: forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
== :: QueryFlag path -> QueryFlag path -> Bool
$c/= :: forall (path :: Symbol). QueryFlag path -> QueryFlag path -> Bool
/= :: QueryFlag path -> QueryFlag path -> Bool
Eq, Int -> QueryFlag path -> ShowS
[QueryFlag path] -> ShowS
QueryFlag path -> [Char]
(Int -> QueryFlag path -> ShowS)
-> (QueryFlag path -> [Char])
-> ([QueryFlag path] -> ShowS)
-> Show (QueryFlag path)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol). Int -> QueryFlag path -> ShowS
forall (path :: Symbol). [QueryFlag path] -> ShowS
forall (path :: Symbol). QueryFlag path -> [Char]
$cshowsPrec :: forall (path :: Symbol). Int -> QueryFlag path -> ShowS
showsPrec :: Int -> QueryFlag path -> ShowS
$cshow :: forall (path :: Symbol). QueryFlag path -> [Char]
show :: QueryFlag path -> [Char]
$cshowList :: forall (path :: Symbol). [QueryFlag path] -> ShowS
showList :: [QueryFlag path] -> ShowS
Show)
-----------------------------------------------------------------------------
-- | Type used for representing query parameters
newtype QueryParam (path :: Symbol) a = QueryParam (Maybe a)
  deriving stock (QueryParam path a -> QueryParam path a -> Bool
(QueryParam path a -> QueryParam path a -> Bool)
-> (QueryParam path a -> QueryParam path a -> Bool)
-> Eq (QueryParam path a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
$c== :: forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
== :: QueryParam path a -> QueryParam path a -> Bool
$c/= :: forall (path :: Symbol) a.
Eq a =>
QueryParam path a -> QueryParam path a -> Bool
/= :: QueryParam path a -> QueryParam path a -> Bool
Eq, Int -> QueryParam path a -> ShowS
[QueryParam path a] -> ShowS
QueryParam path a -> [Char]
(Int -> QueryParam path a -> ShowS)
-> (QueryParam path a -> [Char])
-> ([QueryParam path a] -> ShowS)
-> Show (QueryParam path a)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol) a.
Show a =>
Int -> QueryParam path a -> ShowS
forall (path :: Symbol) a. Show a => [QueryParam path a] -> ShowS
forall (path :: Symbol) a. Show a => QueryParam path a -> [Char]
$cshowsPrec :: forall (path :: Symbol) a.
Show a =>
Int -> QueryParam path a -> ShowS
showsPrec :: Int -> QueryParam path a -> ShowS
$cshow :: forall (path :: Symbol) a. Show a => QueryParam path a -> [Char]
show :: QueryParam path a -> [Char]
$cshowList :: forall (path :: Symbol) a. Show a => [QueryParam path a] -> ShowS
showList :: [QueryParam path a] -> ShowS
Show)
-----------------------------------------------------------------------------
-- | Type used for representing fragments
data Fragment (path :: Symbol) = Fragment
  deriving stock (Fragment path -> Fragment path -> Bool
(Fragment path -> Fragment path -> Bool)
-> (Fragment path -> Fragment path -> Bool) -> Eq (Fragment path)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (path :: Symbol). Fragment path -> Fragment path -> Bool
$c== :: forall (path :: Symbol). Fragment path -> Fragment path -> Bool
== :: Fragment path -> Fragment path -> Bool
$c/= :: forall (path :: Symbol). Fragment path -> Fragment path -> Bool
/= :: Fragment path -> Fragment path -> Bool
Eq, Int -> Fragment path -> ShowS
[Fragment path] -> ShowS
Fragment path -> [Char]
(Int -> Fragment path -> ShowS)
-> (Fragment path -> [Char])
-> ([Fragment path] -> ShowS)
-> Show (Fragment path)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (path :: Symbol). Int -> Fragment path -> ShowS
forall (path :: Symbol). [Fragment path] -> ShowS
forall (path :: Symbol). Fragment path -> [Char]
$cshowsPrec :: forall (path :: Symbol). Int -> Fragment path -> ShowS
showsPrec :: Int -> Fragment path -> ShowS
$cshow :: forall (path :: Symbol). Fragment path -> [Char]
show :: Fragment path -> [Char]
$cshowList :: forall (path :: Symbol). [Fragment path] -> ShowS
showList :: [Fragment path] -> ShowS
Show)
-----------------------------------------------------------------------------
instance (KnownSymbol frag) => ToMisoString (Fragment frag) where
  toMisoString :: Fragment frag -> Text
toMisoString Fragment frag
Fragment = Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Proxy frag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @frag))
-----------------------------------------------------------------------------
instance (ToMisoString a, KnownSymbol path) => ToMisoString (QueryParam path a) where
  toMisoString :: QueryParam path a -> Text
toMisoString (QueryParam Maybe a
maybeVal) =
    Text -> (a -> Text) -> Maybe a -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (\a
param -> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall str. ToMisoString str => str -> Text
ms a
param Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val) Maybe a
maybeVal
      where
        val :: Text
val = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy path -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @path)
-----------------------------------------------------------------------------
instance (FromMisoString a, KnownSymbol path) => FromMisoString (QueryParam path a) where
  fromMisoStringEither :: Text -> Either [Char] (QueryParam path a)
fromMisoStringEither Text
x =
    case forall t. FromMisoString t => Text -> Either [Char] t
fromMisoStringEither @a Text
x of
      Right a
r -> QueryParam path a -> Either [Char] (QueryParam path a)
forall a b. b -> Either a b
Right (QueryParam path a -> Either [Char] (QueryParam path a))
-> QueryParam path a -> Either [Char] (QueryParam path a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> QueryParam path a
forall (path :: Symbol) a. Maybe a -> QueryParam path a
QueryParam (a -> Maybe a
forall a. a -> Maybe a
Just a
r)
      Left [Char]
v -> [Char] -> Either [Char] (QueryParam path a)
forall a b. a -> Either a b
Left [Char]
v
-----------------------------------------------------------------------------
instance KnownSymbol name => ToMisoString (QueryFlag name) where
  toMisoString :: QueryFlag name -> Text
toMisoString = \case
    QueryFlag Bool
True ->
      Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name))
    QueryFlag Bool
False ->
      Text
forall a. Monoid a => a
mempty
-----------------------------------------------------------------------------
-- | A list of tokens are returned from a successful lex of a t'URI'
data Token
  = QueryParamTokens [(MisoString, Maybe MisoString)]
  | QueryParamToken MisoString (Maybe MisoString)
  | CaptureOrPathToken MisoString
  | FragmentToken MisoString
  | IndexToken
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
(Int -> Token -> ShowS)
-> (Token -> [Char]) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> [Char]
show :: Token -> [Char]
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Smart constructor for building a 'QueryParamToken'
toQueryParam
  :: ToMisoString s
  => MisoString
  -- ^ Query parameter key
  -> s
  -- ^ Query parameter value
  -> Token
toQueryParam :: forall s. ToMisoString s => Text -> s -> Token
toQueryParam Text
k s
v = Text -> Maybe Text -> Token
QueryParamToken Text
k (Text -> Maybe Text
forall a. a -> Maybe a
Just (s -> Text
forall str. ToMisoString str => str -> Text
ms s
v))
-----------------------------------------------------------------------------
-- | Smart constructor for building a capture variable
toCapture :: ToMisoString string => string -> Token
toCapture :: forall string. ToMisoString string => string -> Token
toCapture = Text -> Token
CaptureOrPathToken (Text -> Token) -> (string -> Text) -> string -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. string -> Text
forall str. ToMisoString str => str -> Text
ms
-----------------------------------------------------------------------------
-- | Smart constructor for building a path fragment
toPath :: MisoString -> Token
toPath :: Text -> Token
toPath = Text -> Token
CaptureOrPathToken
-----------------------------------------------------------------------------
-- | Converts a list of @[Token]@ into an actual @URI@.
tokensToURI :: [Token] -> URI
tokensToURI :: [Token] -> URI
tokensToURI [Token]
tokens = URI
  { uriPath :: Text
uriPath =
      case [Token]
tokens of
        Token
IndexToken : [Token]
_ -> Text
""
        [Token]
_ ->
          Text -> [Text] -> Text
MS.intercalate Text
"/"
          [ Text
x
          | CaptureOrPathToken Text
x <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isPathRelated [Token]
tokens
          ]
  , uriQueryString :: Map Text (Maybe Text)
uriQueryString =
      [Map Text (Maybe Text)] -> Map Text (Maybe Text)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions
        [ case Token
queryToken of
            QueryParamTokens [(Text, Maybe Text)]
queryParams_ ->
              [(Text, Maybe Text)] -> Map Text (Maybe Text)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Maybe Text)]
queryParams_
            QueryParamToken Text
k Maybe Text
v ->
              Text -> Maybe Text -> Map Text (Maybe Text)
forall k a. k -> a -> Map k a
M.singleton Text
k Maybe Text
v
            Token
_ ->
              Map Text (Maybe Text)
forall a. Monoid a => a
mempty
        | Token
queryToken <- (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isQuery [Token]
tokens
        ]
  , uriFragment :: Text
uriFragment =
      (Token -> Text) -> [Token] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Token -> Text
forall str. ToMisoString str => str -> Text
ms ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isFragment [Token]
tokens)
  } where
      isFragment :: Token -> Bool
isFragment = \case
        FragmentToken{} -> Bool
True
        Token
_ -> Bool
False
      isQuery :: Token -> Bool
isQuery = \case
        QueryParamToken{} -> Bool
True
        Token
_ -> Bool
False
      isPathRelated :: Token -> Bool
isPathRelated = \case
        CaptureOrPathToken {} -> Bool
True
        IndexToken {} -> Bool
True
        Token
_ -> Bool
False
-----------------------------------------------------------------------------
instance ToMisoString Token where
  toMisoString :: Token -> Text
toMisoString = \case
    CaptureOrPathToken Text
x -> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
    FragmentToken Text
x -> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
    QueryParamTokens [(Text, Maybe Text)]
params ->
      Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
MS.intercalate Text
"&"
        [ case Maybe Text
value of
            Maybe Text
Nothing -> Text
key
            Just Text
v -> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
        | (Text
key, Maybe Text
value) <- [(Text, Maybe Text)]
params
        ]
    QueryParamToken Text
k (Just Text
v) ->
      Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
    QueryParamToken Text
k Maybe Text
Nothing ->
      Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k
    Token
IndexToken -> Text
"/"
-----------------------------------------------------------------------------
-- | An error that can occur during lexing / parsing of a URI into a user-defined
-- data type
data RoutingError
  = ParseError MisoString [Token]
  | AmbiguousParse MisoString [Token]
  | LexError MisoString MisoString
  | LexErrorEOF MisoString
  | NoParses MisoString
  deriving (Int -> RoutingError -> ShowS
[RoutingError] -> ShowS
RoutingError -> [Char]
(Int -> RoutingError -> ShowS)
-> (RoutingError -> [Char])
-> ([RoutingError] -> ShowS)
-> Show RoutingError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RoutingError -> ShowS
showsPrec :: Int -> RoutingError -> ShowS
$cshow :: RoutingError -> [Char]
show :: RoutingError -> [Char]
$cshowList :: [RoutingError] -> ShowS
showList :: [RoutingError] -> ShowS
Show, RoutingError -> RoutingError -> Bool
(RoutingError -> RoutingError -> Bool)
-> (RoutingError -> RoutingError -> Bool) -> Eq RoutingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RoutingError -> RoutingError -> Bool
== :: RoutingError -> RoutingError -> Bool
$c/= :: RoutingError -> RoutingError -> Bool
/= :: RoutingError -> RoutingError -> Bool
Eq)
-----------------------------------------------------------------------------
-- | State monad for parsing URI
type RouteParser = ParserT URI [Token] []
-----------------------------------------------------------------------------
-- | Combinator for parsing a capture variable out of a URI
capture :: FromMisoString value => RouteParser value
capture :: forall value. FromMisoString value => RouteParser value
capture = do
  CaptureOrPathToken capture_ <- RouteParser Token
captureOrPathToken
  case fromMisoStringEither capture_ of
    Left [Char]
msg -> [Char] -> ParserT URI [Token] [] value
forall a. HasCallStack => [Char] -> ParserT URI [Token] [] a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail (Text -> [Char]
forall a. FromMisoString a => Text -> a
fromMisoString ([Char] -> Text
forall str. ToMisoString str => str -> Text
ms [Char]
msg))
    Right value
token -> value -> ParserT URI [Token] [] value
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure value
token
-----------------------------------------------------------------------------
-- | Combinator for parsing a path out of a URI
path :: MisoString -> RouteParser MisoString
path :: Text -> RouteParser Text
path Text
specified = do
  CaptureOrPathToken parsed <- RouteParser Token
captureOrPathToken
  when (specified /= parsed) (fail "path")
  pure specified
-----------------------------------------------------------------------------
index :: MisoString -> RouteParser MisoString
index :: Text -> RouteParser Text
index Text
specified = do
  Token -> RouteParser Text
IndexToken <- RouteParser Token
indexToken
  when (specified /= "index") (fail "index")
  pure "/"
-----------------------------------------------------------------------------
-- | Matches a literal URI fragment (the part after @#@), failing the parse if
-- it differs. Returns the matched fragment.
fragment :: MisoString -> RouteParser MisoString
fragment :: Text -> RouteParser Text
fragment Text
specified = do
  FragmentToken frag <- RouteParser Token
indexToken
  when (specified /= frag) (fail "fragment")
  pure frag
-----------------------------------------------------------------------------
-- | URI parsing
parseURI :: MisoString -> Either MisoString URI
parseURI :: Text -> Either Text URI
parseURI Text
txt =
  case Text -> Either LexerError [Token]
lexTokens Text
txt of
    Left (L.LexerError Text
err Location
_) -> Text -> Either Text URI
forall a b. a -> Either a b
Left Text
err
    Left (L.UnexpectedEOF Location
eof) -> Text -> Either Text URI
forall a b. a -> Either a b
Left (Text
"EOF: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Location -> [Char]
forall a. Show a => a -> [Char]
show Location
eof))
    Right [Token]
tokens -> URI -> Either Text URI
forall a b. b -> Either a b
Right ([Token] -> URI
tokensToURI [Token]
tokens)
-----------------------------------------------------------------------------
instance FromMisoString URI where
    fromMisoStringEither :: Text -> Either [Char] URI
fromMisoStringEither = (Text -> [Char]) -> Either Text URI -> Either [Char] URI
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
forall a. FromMisoString a => Text -> a
fromMisoString (Either Text URI -> Either [Char] URI)
-> (Text -> Either Text URI) -> Text -> Either [Char] URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text URI
parseURI
-----------------------------------------------------------------------------
instance FromJSON URI where
    parseJSON :: Value -> Parser URI
parseJSON = ([Char] -> Parser URI)
-> (URI -> Parser URI) -> Either [Char] URI -> Parser URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Parser URI
forall a. HasCallStack => [Char] -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail URI -> Parser URI
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] URI -> Parser URI)
-> (Text -> Either [Char] URI) -> Text -> Parser URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either [Char] URI
forall t. FromMisoString t => Text -> Either [Char] t
fromMisoStringEither (Text -> Parser URI)
-> (Value -> Parser Text) -> Value -> Parser URI
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON
-----------------------------------------------------------------------------
-- | Class used to facilitate routing for miso applications
class Router route where
  fromRoute :: route -> [Token]
  default fromRoute :: (Generic route, GRouter (Rep route)) => route -> [Token]
  fromRoute = Rep route (ZonkAny 0) -> [Token]
forall route. Rep route route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute (Rep route (ZonkAny 0) -> [Token])
-> (route -> Rep route (ZonkAny 0)) -> route -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> Rep route (ZonkAny 0)
forall x. route -> Rep route x
forall a x. Generic a => a -> Rep a x
from

  -- | Convert a 'Router route => route' into a t'URI'
  toURI :: route -> URI
  toURI = [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute

  -- | Map a URI back to a route
  route :: URI -> Either RoutingError route
  route = Text -> Either RoutingError route
forall route. Router route => Text -> Either RoutingError route
toRoute (Text -> Either RoutingError route)
-> (URI -> Text) -> URI -> Either RoutingError route
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Text
prettyURI

  -- | Convenience for specifying a URL as a hyperlink reference in 'Miso.Types.View'
  href_ :: route -> Attribute model action
  href_ = Text -> Attribute model action
forall model action. Text -> Attribute model action
P.href_ (Text -> Attribute model action)
-> (route -> Text) -> route -> Attribute model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> Text
forall route. Router route => route -> Text
prettyRoute

  -- | Route pretty printing
  prettyRoute :: route -> MisoString
  prettyRoute = URI -> Text
prettyURI (URI -> Text) -> (route -> URI) -> route -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute

  -- | Route debugging
  dumpURI :: route -> MisoString
  dumpURI = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms ([Char] -> Text) -> (route -> [Char]) -> route -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
forall a. Show a => a -> [Char]
show (URI -> [Char]) -> (route -> URI) -> route -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> URI
tokensToURI ([Token] -> URI) -> (route -> [Token]) -> route -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. route -> [Token]
forall route. Router route => route -> [Token]
fromRoute

  -- | Route parsing from a 'MisoString'
  toRoute :: MisoString -> Either RoutingError route
  toRoute Text
input = Text -> RouteParser route -> Either RoutingError route
forall a. Text -> RouteParser a -> Either RoutingError a
parseRoute Text
input RouteParser route
forall route. Router route => RouteParser route
routeParser

  routeParser :: RouteParser route
  default routeParser :: (Generic route, GRouter (Rep route)) => RouteParser route
  routeParser = Rep route (ZonkAny 1) -> route
forall a x. Generic a => Rep a x -> a
forall x. Rep route x -> route
to (Rep route (ZonkAny 1) -> route)
-> ParserT URI [Token] [] (Rep route (ZonkAny 1))
-> RouteParser route
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (Rep route (ZonkAny 1))
forall route. RouteParser (Rep route route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
-----------------------------------------------------------------------------
-- | Smart constructor for building a @RouteParser@
--
-- @
--
-- data Route = Widget MisoString Int
--
-- instance Router Route where
--   routeParser = routes [ Widget \<$\> path "widget" \<*\> capture ]
--   fromRoute (Widget path value) = [ toPath path, toCapture value ]
--
-- router :: Router router => RouteParser router
-- router = routes [ Widget \<$\> path "widget" \<*\> capture ]
--
-- > Right (Widget "widget" 10)
-- @
--
-----------------------------------------------------------------------------
runRouter
  :: MisoString
  -- ^ The raw URL string to parse
  -> RouteParser route
  -- ^ Parser to apply against the tokenised URL
  -> Either RoutingError route
runRouter :: forall a. Text -> RouteParser a -> Either RoutingError a
runRouter = Text -> RouteParser route -> Either RoutingError route
forall a. Text -> RouteParser a -> Either RoutingError a
parseRoute
-----------------------------------------------------------------------------
-- | Convenience for specifying multiple routes
routes :: [ RouteParser route ] -> RouteParser route
routes :: forall route. [RouteParser route] -> RouteParser route
routes = (RouteParser route -> RouteParser route -> RouteParser route)
-> RouteParser route -> [RouteParser route] -> RouteParser route
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RouteParser route -> RouteParser route -> RouteParser route
forall a.
ParserT URI [Token] [] a
-> ParserT URI [Token] [] a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) RouteParser route
forall a. ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a
empty
-----------------------------------------------------------------------------
-- | Generic deriving for 'Router'
class GRouter f where
  gFromRoute :: f route -> [Token]
  gRouteParser :: RouteParser (f route)
-----------------------------------------------------------------------------
instance GRouter next => GRouter (D1 m next) where
  gFromRoute :: forall (route :: k). D1 m next route -> [Token]
gFromRoute (M1 next route
x) = next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
  gRouteParser :: forall (route :: k). RouteParser (D1 m next route)
gRouteParser = next route -> M1 D m next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> M1 D m next route)
-> ParserT URI [Token] [] (next route)
-> ParserT URI [Token] [] (M1 D m next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
-----------------------------------------------------------------------------
instance (KnownSymbol name, GRouter next) => GRouter (C1 ('MetaCons name x y) next) where
  gFromRoute :: forall (route :: k). C1 ('MetaCons name x y) next route -> [Token]
gFromRoute (M1 next route
x) =
    case Text
name of
      Text
"index" -> [Token
IndexToken]
      Text
_ -> Text -> Token
CaptureOrPathToken Text
name Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
      where
        name :: Text
name = [Char] -> Text
lowercaseStrip ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
  gRouteParser :: forall (route :: k).
RouteParser (C1 ('MetaCons name x y) next route)
gRouteParser = do
    case Text
name of
      Text
"index" -> do
        RouteParser Text -> ParserT URI [Token] [] ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> RouteParser Text
index Text
name)
        next route -> C1 ('MetaCons name x y) next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> C1 ('MetaCons name x y) next route)
-> ParserT URI [Token] [] (next route)
-> RouteParser (C1 ('MetaCons name x y) next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
      Text
_ -> do
        RouteParser Text -> ParserT URI [Token] [] ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> RouteParser Text
path Text
name)
        next route -> C1 ('MetaCons name x y) next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> C1 ('MetaCons name x y) next route)
-> ParserT URI [Token] [] (next route)
-> RouteParser (C1 ('MetaCons name x y) next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
      where
        name :: Text
name = [Char] -> Text
lowercaseStrip ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)
-----------------------------------------------------------------------------
instance GRouter next => GRouter (S1 m next) where
  gFromRoute :: forall (route :: k). S1 m next route -> [Token]
gFromRoute (M1 next route
x) = next route -> [Token]
forall (route :: k). next route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute next route
x
  gRouteParser :: forall (route :: k). RouteParser (S1 m next route)
gRouteParser = next route -> M1 S m next route
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (next route -> M1 S m next route)
-> ParserT URI [Token] [] (next route)
-> ParserT URI [Token] [] (M1 S m next route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (next route)
forall (route :: k). RouteParser (next route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
-----------------------------------------------------------------------------
instance {-# OVERLAPS #-} forall path m . KnownSymbol path => GRouter (K1 m (Path path)) where
  gFromRoute :: forall (route :: k). K1 m (Path path) route -> [Token]
gFromRoute (K1 Path path
x) = Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> Token
CaptureOrPathToken (Path path -> Text
forall str. ToMisoString str => str -> Text
ms Path path
x)
  gRouteParser :: forall (route :: k). RouteParser (K1 m (Path path) route)
gRouteParser = Path path -> K1 m (Path path) route
forall k i c (p :: k). c -> K1 i c p
K1 (Text -> Path path
forall (path :: Symbol). Text -> Path path
Path Text
chunk) K1 m (Path path) route
-> RouteParser Text
-> ParserT URI [Token] [] (K1 m (Path path) route)
forall a b.
a -> ParserT URI [Token] [] b -> ParserT URI [Token] [] a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> RouteParser Text
path Text
chunk
    where
      chunk :: Text
chunk = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy path -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy path
forall {k} (t :: k). Proxy t
Proxy :: Proxy path)
-----------------------------------------------------------------------------
instance {-# OVERLAPS #-} (FromMisoString a, ToMisoString a) => GRouter (K1 m (Capture sym a)) where
  gFromRoute :: forall (route :: k). K1 m (Capture sym a) route -> [Token]
gFromRoute (K1 Capture sym a
x) = Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> Token
CaptureOrPathToken (Capture sym a -> Text
forall str. ToMisoString str => str -> Text
ms Capture sym a
x)
  gRouteParser :: forall (route :: k). RouteParser (K1 m (Capture sym a) route)
gRouteParser = Capture sym a -> K1 m (Capture sym a) route
forall k i c (p :: k). c -> K1 i c p
K1 (Capture sym a -> K1 m (Capture sym a) route)
-> ParserT URI [Token] [] (Capture sym a)
-> ParserT URI [Token] [] (K1 m (Capture sym a) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (Capture sym a)
forall value. FromMisoString value => RouteParser value
capture
-----------------------------------------------------------------------------
instance {-# OVERLAPS #-} KnownSymbol frag => GRouter (K1 m (Fragment frag)) where
  gFromRoute :: forall (route :: k). K1 m (Fragment frag) route -> [Token]
gFromRoute (K1 Fragment frag
x) = Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> [Token]) -> Token -> [Token]
forall a b. (a -> b) -> a -> b
$ Text -> Token
FragmentToken (Fragment frag -> Text
forall str. ToMisoString str => str -> Text
ms Fragment frag
x)
  gRouteParser :: forall (route :: k). RouteParser (K1 m (Fragment frag) route)
gRouteParser = Fragment frag -> K1 m (Fragment frag) route
forall k i c (p :: k). c -> K1 i c p
K1 Fragment frag
forall (path :: Symbol). Fragment path
Fragment K1 m (Fragment frag) route
-> RouteParser Text
-> ParserT URI [Token] [] (K1 m (Fragment frag) route)
forall a b.
a -> ParserT URI [Token] [] b -> ParserT URI [Token] [] a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> RouteParser Text
fragment Text
frag
    where
      frag :: Text
frag = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Proxy frag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy frag
forall {k} (t :: k). Proxy t
Proxy :: Proxy frag))
-----------------------------------------------------------------------------
instance {-# OVERLAPS #-} forall param m a . (ToMisoString a, FromMisoString a, KnownSymbol param) =>
  GRouter (K1 m (QueryParam param a)) where
    gFromRoute :: forall (route :: k). K1 m (QueryParam param a) route -> [Token]
gFromRoute (K1 (QueryParam Maybe a
maybeParam)) = do
      let key :: Text
key = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Proxy param -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @param))
      case Maybe a
maybeParam of
        Maybe a
Nothing -> [Text -> Maybe Text -> Token
QueryParamToken Text
key Maybe Text
forall a. Maybe a
Nothing]
        Just a
v -> [Text -> Maybe Text -> Token
QueryParamToken Text
key (Text -> Maybe Text
forall a. a -> Maybe a
Just (a -> Text
forall str. ToMisoString str => str -> Text
ms a
v))]
    gRouteParser :: forall (route :: k). RouteParser (K1 m (QueryParam param a) route)
gRouteParser = QueryParam param a -> K1 m (QueryParam param a) route
forall k i c (p :: k). c -> K1 i c p
K1 (QueryParam param a -> K1 m (QueryParam param a) route)
-> ParserT URI [Token] [] (QueryParam param a)
-> ParserT URI [Token] [] (K1 m (QueryParam param a) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (QueryParam param a)
forall (param :: Symbol) a.
(FromMisoString a, KnownSymbol param) =>
RouteParser (QueryParam param a)
queryParam
-----------------------------------------------------------------------------
-- | Query parameter parser from a route
queryParam
  :: forall param a . (FromMisoString a, KnownSymbol param)
  => RouteParser (QueryParam param a)
queryParam :: forall (param :: Symbol) a.
(FromMisoString a, KnownSymbol param) =>
RouteParser (QueryParam param a)
queryParam = do
  URI {..} <- ParserT URI [Token] [] URI
forall r token. ParserT r token [] r
askParser
  QueryParam <$> do
    case M.lookup (ms (symbolVal (Proxy @param))) uriQueryString of
      Just (Just Text
value) ->
        case Text -> Either [Char] a
forall t. FromMisoString t => Text -> Either [Char] t
fromMisoStringEither Text
value of
          Left [Char]
_ -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
          Right a
parsed -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
parsed)
      Maybe (Maybe Text)
_ -> Maybe a -> ParserT URI [Token] [] (Maybe a)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------
instance {-# OVERLAPS #-} forall flag m . KnownSymbol flag => GRouter (K1 m (QueryFlag flag)) where
  gFromRoute :: forall (route :: k). K1 m (QueryFlag flag) route -> [Token]
gFromRoute (K1 (QueryFlag Bool
specified))
    | Bool
specified = [ Text -> Maybe Text -> Token
QueryParamToken Text
flag Maybe Text
forall a. Maybe a
Nothing ]
    | Bool
otherwise = []
        where
          flag :: Text
flag = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Proxy flag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @flag))
  gRouteParser :: forall (route :: k). RouteParser (K1 m (QueryFlag flag) route)
gRouteParser = QueryFlag flag -> K1 m (QueryFlag flag) route
forall k i c (p :: k). c -> K1 i c p
K1 (QueryFlag flag -> K1 m (QueryFlag flag) route)
-> ParserT URI [Token] [] (QueryFlag flag)
-> ParserT URI [Token] [] (K1 m (QueryFlag flag) route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (QueryFlag flag)
forall (flag :: Symbol).
KnownSymbol flag =>
RouteParser (QueryFlag flag)
queryFlag
-----------------------------------------------------------------------------
-- | Query flag parser from a route
queryFlag :: forall flag . KnownSymbol flag => RouteParser (QueryFlag flag)
queryFlag :: forall (flag :: Symbol).
KnownSymbol flag =>
RouteParser (QueryFlag flag)
queryFlag = do
  URI {..} <- ParserT URI [Token] [] URI
forall r token. ParserT r token [] r
askParser
  pure $ QueryFlag $ isJust (M.lookup flag uriQueryString)
    where
      flag :: Text
flag = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy flag -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @flag)
-----------------------------------------------------------------------------
instance Router a => GRouter (K1 m a) where
  gFromRoute :: forall (route :: k). K1 m a route -> [Token]
gFromRoute (K1 a
x) = a -> [Token]
forall route. Router route => route -> [Token]
fromRoute a
x
  gRouteParser :: forall (route :: k). RouteParser (K1 m a route)
gRouteParser = a -> K1 m a route
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 m a route)
-> ParserT URI [Token] [] a
-> ParserT URI [Token] [] (K1 m a route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] a
forall route. Router route => RouteParser route
routeParser
-----------------------------------------------------------------------------
instance GRouter U1 where
  gFromRoute :: forall (route :: k). U1 route -> [Token]
gFromRoute U1 route
U1 = []
  gRouteParser :: forall (route :: k). RouteParser (U1 route)
gRouteParser = U1 route -> ParserT URI [Token] [] (U1 route)
forall a. a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 route
forall k (p :: k). U1 p
U1
-----------------------------------------------------------------------------
instance (GRouter left, GRouter right) => GRouter (left :*: right) where
  gFromRoute :: forall (route :: k). (:*:) left right route -> [Token]
gFromRoute (left route
left :*: right route
right) = left route -> [Token]
forall (route :: k). left route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute left route
left [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> right route -> [Token]
forall (route :: k). right route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute right route
right
  gRouteParser :: forall (route :: k). RouteParser ((:*:) left right route)
gRouteParser = (left route -> right route -> (:*:) left right route)
-> ParserT URI [Token] [] (left route)
-> ParserT URI [Token] [] (right route)
-> ParserT URI [Token] [] ((:*:) left right route)
forall a b c.
(a -> b -> c)
-> ParserT URI [Token] [] a
-> ParserT URI [Token] [] b
-> ParserT URI [Token] [] c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 left route -> right route -> (:*:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) ParserT URI [Token] [] (left route)
forall (route :: k). RouteParser (left route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser ParserT URI [Token] [] (right route)
forall (route :: k). RouteParser (right route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
-----------------------------------------------------------------------------
instance (GRouter left, GRouter right) => GRouter (left :+: right) where
  gFromRoute :: forall (route :: k). (:+:) left right route -> [Token]
gFromRoute = \case
    L1 left route
m1 -> left route -> [Token]
forall (route :: k). left route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute left route
m1
    R1 right route
m1 -> right route -> [Token]
forall (route :: k). right route -> [Token]
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
f route -> [Token]
gFromRoute right route
m1
  gRouteParser :: forall (route :: k). RouteParser ((:+:) left right route)
gRouteParser = (ParserT URI [Token] [] ((:+:) left right route)
 -> ParserT URI [Token] [] ((:+:) left right route)
 -> ParserT URI [Token] [] ((:+:) left right route))
-> ParserT URI [Token] [] ((:+:) left right route)
-> [ParserT URI [Token] [] ((:+:) left right route)]
-> ParserT URI [Token] [] ((:+:) left right route)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall a.
ParserT URI [Token] [] a
-> ParserT URI [Token] [] a -> ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ParserT URI [Token] [] ((:+:) left right route)
forall a. ParserT URI [Token] [] a
forall (f :: * -> *) a. Alternative f => f a
empty
    [ left route -> (:+:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (left route -> (:+:) left right route)
-> ParserT URI [Token] [] (left route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (left route)
forall (route :: k). RouteParser (left route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
    , right route -> (:+:) left right route
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (right route -> (:+:) left right route)
-> ParserT URI [Token] [] (right route)
-> ParserT URI [Token] [] ((:+:) left right route)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT URI [Token] [] (right route)
forall (route :: k). RouteParser (right route)
forall {k} (f :: k -> *) (route :: k).
GRouter f =>
RouteParser (f route)
gRouteParser
    ]
-----------------------------------------------------------------------------
captureOrPathToken :: RouteParser Token
captureOrPathToken :: RouteParser Token
captureOrPathToken = (Token -> Bool) -> RouteParser Token
forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy ((Token -> Bool) -> RouteParser Token)
-> (Token -> Bool) -> RouteParser Token
forall a b. (a -> b) -> a -> b
$ \case
  CaptureOrPathToken {} -> Bool
True
  Token
_ -> Bool
False
-----------------------------------------------------------------------------
indexToken :: RouteParser Token
indexToken :: RouteParser Token
indexToken = (Token -> Bool) -> RouteParser Token
forall a r. (a -> Bool) -> ParserT r [a] [] a
satisfy ((Token -> Bool) -> RouteParser Token)
-> (Token -> Bool) -> RouteParser Token
forall a b. (a -> b) -> a -> b
$ \case
  IndexToken {} -> Bool
True
  Token
_ -> Bool
False
-----------------------------------------------------------------------------
-- | Lexing for a URI
uriLexer :: Lexer [Token]
uriLexer :: Lexer [Token]
uriLexer = do
  tokens <- Lexer Token -> Lexer [Token]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Lexer Token
lexer
  void $ optional (L.char '/')
  pure (postProcess tokens)
    where
      postProcess :: [Token] -> [Token]
      postProcess :: [Token] -> [Token]
postProcess = (Token -> [Token]) -> [Token] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Token -> [Token]) -> [Token] -> [Token])
-> (Token -> [Token]) -> [Token] -> [Token]
forall a b. (a -> b) -> a -> b
$ \case
        QueryParamTokens [(Text, Maybe Text)]
queryParams_ ->
          [ Text -> Maybe Text -> Token
QueryParamToken Text
k Maybe Text
v
          | (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
queryParams_
          ]
        Token
x -> Token -> [Token]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token
x
      lexer :: Lexer Token
lexer = [Lexer Token] -> Lexer Token
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        [ Lexer Token
captureOrPathLexer
        , Lexer Token
queryParamLexer
        , Lexer Token
fragmentLexer
        , Lexer Token
indexLexer
        ] where
            indexLexer :: Lexer Token
indexLexer =
              Token
IndexToken Token -> Lexer Char -> Lexer Token
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Lexer Char
L.char Char
'/'
            captureOrPathLexer :: Lexer Token
captureOrPathLexer = do
              Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'/')
              Text -> Token
CaptureOrPathToken (Text -> Token) -> Lexer Text -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text
chars
            fragmentLexer :: Lexer Token
fragmentLexer = do
              Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'#')
              Text -> Token
FragmentToken (Text -> Token) -> Lexer Text -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text
query
            queryParamLexer :: Lexer Token
queryParamLexer = [(Text, Maybe Text)] -> Token
QueryParamTokens ([(Text, Maybe Text)] -> Token)
-> Lexer [(Text, Maybe Text)] -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Lexer Char -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Lexer Char
L.char Char
'?')
              Lexer Char
-> Lexer (Text, Maybe Text) -> Lexer [(Text, Maybe Text)]
forall (m :: * -> *) sep a. Alternative m => m sep -> m a -> m [a]
sepBy (Char -> Lexer Char
L.char Char
'&') (Lexer (Text, Maybe Text) -> Lexer [(Text, Maybe Text)])
-> Lexer (Text, Maybe Text) -> Lexer [(Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ do
                key <- Lexer Text
query
                maybeValue <-
                  optional $ do
                    void (L.char '=')
                    query
                pure (key, maybeValue)
-----------------------------------------------------------------------------
chars :: Lexer MisoString
chars :: Lexer Text
chars = [Text] -> Text
MS.concat ([Text] -> Text) -> Lexer [Text] -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text -> Lexer [Text]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Lexer Text
pchar
-----------------------------------------------------------------------------
pchar :: Lexer MisoString
pchar :: Lexer Text
pchar = Lexer Text
unreserved Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Lexer Text
pctEncoded Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Lexer Text
subDelims Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Lexer Text
L.string Text
":" Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Lexer Text
L.string Text
"@"
-----------------------------------------------------------------------------
query :: Lexer MisoString
query :: Lexer Text
query = (Lexer Text -> Lexer Text -> Lexer Text)
-> Lexer Text -> [Lexer Text] -> Lexer Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) Lexer Text
forall a. Lexer a
forall (f :: * -> *) a. Alternative f => f a
empty
  [ [Text] -> Text
MS.concat ([Text] -> Text) -> Lexer [Text] -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexer Text -> Lexer [Text]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Lexer Text
pchar
  ]
-----------------------------------------------------------------------------
subDelims :: Lexer MisoString
subDelims :: Lexer Text
subDelims = (Char -> Text) -> Lexer Char -> Lexer Text
forall a b. (a -> b) -> Lexer a -> Lexer b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Text
forall str. ToMisoString str => str -> Text
ms (Lexer Char -> Lexer Text)
-> ((Char -> Bool) -> Lexer Char) -> (Char -> Bool) -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Lexer Char
L.satisfy ((Char -> Bool) -> Lexer Text) -> (Char -> Bool) -> Lexer Text
forall a b. (a -> b) -> a -> b
$ \Char
x -> Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"!$'()*+,;" :: String)
-----------------------------------------------------------------------------
unreserved :: Lexer MisoString
unreserved :: Lexer Text
unreserved = Char -> Text
forall str. ToMisoString str => str -> Text
ms (Char -> Text) -> Lexer Char -> Lexer Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  (Char -> Bool) -> Lexer Char
L.satisfy ((Char -> Bool) -> Lexer Char) -> (Char -> Bool) -> Lexer Char
forall a b. (a -> b) -> a -> b
$ \Char
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
    [ Char -> Bool
C.isAlphaNum Char
x
    , Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
    , Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
    , Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    , Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'~'
    ]
-----------------------------------------------------------------------------
pctEncoded :: Lexer MisoString
pctEncoded :: Lexer Text
pctEncoded = do
  pct <- Char -> Lexer Char
L.char Char
'%'
  d1 <- hexDig
  d2 <- hexDig
  pure (ms pct <> ms d1 <> ms d2)
-----------------------------------------------------------------------------
hexDig :: Lexer Char
hexDig :: Lexer Char
hexDig = (Char -> Bool) -> Lexer Char
L.satisfy Char -> Bool
C.isHexDigit
-----------------------------------------------------------------------------
-- | Lexes a URI into route t'Token's, or reports where lexing failed.
lexTokens :: MisoString -> Either L.LexerError [Token]
lexTokens :: Text -> Either LexerError [Token]
lexTokens Text
input =
  case Lexer [Token] -> Stream -> Either LexerError ([Token], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
L.runLexer Lexer [Token]
uriLexer (Text -> Stream
L.mkStream Text
input) of
    Right ([Token]
tokens, Stream
_) -> [Token] -> Either LexerError [Token]
forall a b. b -> Either a b
Right [Token]
tokens
    Left LexerError
x -> LexerError -> Either LexerError [Token]
forall a b. a -> Either a b
Left LexerError
x
-----------------------------------------------------------------------------
parseRoute :: MisoString -> RouteParser a -> Either RoutingError a
parseRoute :: forall a. Text -> RouteParser a -> Either RoutingError a
parseRoute Text
input RouteParser a
parser =
  case Lexer [Token] -> Stream -> Either LexerError ([Token], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
L.runLexer Lexer [Token]
uriLexer (Text -> Stream
L.mkStream Text
input) of
    Left (L.LexerError Text
lexErrorMessage Location
_) ->
      RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (Text -> Text -> RoutingError
LexError Text
input Text
lexErrorMessage)
    Left (L.UnexpectedEOF Location
_) ->
      RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (Text -> RoutingError
LexErrorEOF Text
input)
    Right ([Token]
tokens, Stream
_) -> do
      let
        uri :: URI
uri = [Token] -> URI
tokensToURI [Token]
tokens
        isCapturePathOrIndex :: Token -> Bool
isCapturePathOrIndex = \case
          CaptureOrPathToken{} -> Bool
True
          IndexToken{} -> Bool
True
          Token
_ -> Bool
False
      case RouteParser a -> URI -> [Token] -> [(a, [Token])]
forall r token (m :: * -> *) a.
ParserT r token m a -> r -> token -> m (a, token)
runParserT RouteParser a
parser URI
uri ((Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isCapturePathOrIndex [Token]
tokens) of
        [(a
x, [])]  ->
          a -> Either RoutingError a
forall a b. b -> Either a b
Right a
x
        [(a
_, [Token]
leftovers)]  ->
          RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ Text -> [Token] -> RoutingError
ParseError Text
input [Token]
leftovers
        []  ->
          RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ Text -> RoutingError
NoParses Text
input
        (a
_, [Token]
leftovers) : [(a, [Token])]
_  ->
          RoutingError -> Either RoutingError a
forall a b. a -> Either a b
Left (RoutingError -> Either RoutingError a)
-> RoutingError -> Either RoutingError a
forall a b. (a -> b) -> a -> b
$ Text -> [Token] -> RoutingError
AmbiguousParse Text
input [Token]
leftovers
-----------------------------------------------------------------------------
lowercaseStrip :: String -> MisoString
lowercaseStrip :: [Char] -> Text
lowercaseStrip (Char
x:[Char]
xs) = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms (Char -> Char
C.toLower Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
C.isLower [Char]
xs)
lowercaseStrip [Char]
x = [Char] -> Text
forall str. ToMisoString str => str -> Text
ms [Char]
x
-----------------------------------------------------------------------------