{-# LANGUAGE TypeOperators #-}
module Web.Routes.Boomerang
( module Text.Boomerang
, module Text.Boomerang.Texts
, Router
, boomerangSite
, boomerangSiteRouteT
, boomerangFromPathSegments
, boomerangToPathSegments
) where
import Data.Function (on)
import Data.List (maximumBy)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Text.Boomerang
import Text.Boomerang.Texts
import Text.ParserCombinators.Parsec.Prim (State(..), getParserState, setParserState)
import Text.Parsec.Pos (sourceLine, sourceColumn, setSourceColumn, setSourceLine)
import Web.Routes (RouteT(..), Site(..), PathInfo(..), URLParser)
type Router a b = Boomerang TextsError [Text] a b
boomerangSite :: ((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> Router () (url :- ())
-> Site url a
boomerangSite :: ((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> Router () (url :- ()) -> Site url a
boomerangSite (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handler r :: Router () (url :- ())
r@(Boomerang Parser TextsError [Text] (() -> url :- ())
pf (url :- ()) -> [([Text] -> [Text], ())]
sf) =
Site :: forall url a.
((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> (url -> ([Text], [(Text, Maybe Text)]))
-> ([Text] -> Either String url)
-> Site url a
Site { handleSite :: (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handleSite = (url -> [(Text, Maybe Text)] -> Text) -> url -> a
handler
, formatPathSegments :: url -> ([Text], [(Text, Maybe Text)])
formatPathSegments = \url
url ->
case Router () (url :- ()) -> url -> Maybe [Text]
forall e r. Boomerang e [Text] () (r :- ()) -> r -> Maybe [Text]
unparseTexts Router () (url :- ())
r url
url of
Maybe [Text]
Nothing -> String -> ([Text], [(Text, Maybe Text)])
forall a. HasCallStack => String -> a
error String
"formatPathSegments failed to produce a url"
(Just [Text]
ps) -> ([Text]
ps, [])
, parsePathSegments :: [Text] -> Either String url
parsePathSegments = \[Text]
paths -> (TextsError -> String)
-> Either TextsError url -> Either String url
forall a a b. (a -> a) -> Either a b -> Either a b
mapLeft ([Text] -> TextsError -> String
forall a. Show a => a -> TextsError -> String
showErrors [Text]
paths) (Router () (url :- ()) -> [Text] -> Either TextsError url
forall r.
Boomerang TextsError [Text] () (r :- ())
-> [Text] -> Either TextsError r
parseTexts Router () (url :- ())
r [Text]
paths)
}
where
mapLeft :: (a -> a) -> Either a b -> Either a b
mapLeft a -> a
f = (a -> Either a b) -> (b -> Either a b) -> Either a b -> Either a b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> (a -> a) -> a -> Either a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f) b -> Either a b
forall a b. b -> Either a b
Right
showErrors :: a -> TextsError -> String
showErrors a
paths TextsError
err = ((MajorMinorPos -> String) -> TextsError -> String
forall pos. (pos -> String) -> ParserError pos -> String
showParserError MajorMinorPos -> String
showPos TextsError
err) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" while parsing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
paths
showPos :: MajorMinorPos -> String
showPos (MajorMinorPos Integer
s Integer
c) = String
"path segment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
c
boomerangSiteRouteT :: (url -> RouteT url m a)
-> Router () (url :- ())
-> Site url (m a)
boomerangSiteRouteT :: (url -> RouteT url m a) -> Router () (url :- ()) -> Site url (m a)
boomerangSiteRouteT url -> RouteT url m a
handler Router () (url :- ())
router = ((url -> [(Text, Maybe Text)] -> Text) -> url -> m a)
-> Router () (url :- ()) -> Site url (m a)
forall url a.
((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> Router () (url :- ()) -> Site url a
boomerangSite ((url -> (url -> [(Text, Maybe Text)] -> Text) -> m a)
-> (url -> [(Text, Maybe Text)] -> Text) -> url -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((url -> (url -> [(Text, Maybe Text)] -> Text) -> m a)
-> (url -> [(Text, Maybe Text)] -> Text) -> url -> m a)
-> (url -> (url -> [(Text, Maybe Text)] -> Text) -> m a)
-> (url -> [(Text, Maybe Text)] -> Text)
-> url
-> m a
forall a b. (a -> b) -> a -> b
$ RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a)
-> (url -> RouteT url m a)
-> url
-> (url -> [(Text, Maybe Text)] -> Text)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. url -> RouteT url m a
handler) Router () (url :- ())
router
boomerangFromPathSegments :: Boomerang TextsError [Text] () (url :- ()) -> URLParser url
boomerangFromPathSegments :: Boomerang TextsError [Text] () (url :- ()) -> URLParser url
boomerangFromPathSegments (Boomerang Parser TextsError [Text] (() -> url :- ())
prs (url :- ()) -> [([Text] -> [Text], ())]
_) =
do State [Text] ()
st <- ParsecT [Text] () Identity (State [Text] ())
forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
let results :: [Either TextsError ((() -> url :- (), [Text]), Pos TextsError)]
results = Parser TextsError [Text] (() -> url :- ())
-> [Text]
-> Pos TextsError
-> [Either TextsError ((() -> url :- (), [Text]), Pos TextsError)]
forall e tok a.
Parser e tok a -> tok -> Pos e -> [Either e ((a, tok), Pos e)]
runParser Parser TextsError [Text] (() -> url :- ())
prs (State [Text] () -> [Text]
forall s u. State s u -> s
stateInput State [Text] ()
st) (Integer -> Integer -> MajorMinorPos
MajorMinorPos (Line -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Line -> Integer) -> Line -> Integer
forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
sourceLine (State [Text] () -> SourcePos
forall s u. State s u -> SourcePos
statePos State [Text] ()
st)) (Line -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Line -> Integer) -> Line -> Integer
forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
sourceColumn (State [Text] () -> SourcePos
forall s u. State s u -> SourcePos
statePos State [Text] ()
st)))
successes :: [((url :- (), [Text]), MajorMinorPos)]
successes = [ ((() -> url :- ()
f (), [Text]
tok), MajorMinorPos
pos) | (Right ((() -> url :- ()
f, [Text]
tok), MajorMinorPos
pos)) <- [Either TextsError ((() -> url :- (), [Text]), MajorMinorPos)]
results]
case [((url :- (), [Text]), MajorMinorPos)]
successes of
[] -> String -> URLParser url
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((MajorMinorPos -> String) -> TextsError -> String
forall pos. (pos -> String) -> ParserError pos -> String
showParserError (String -> MajorMinorPos -> String
forall a b. a -> b -> a
const String
"") (TextsError -> String) -> TextsError -> String
forall a b. (a -> b) -> a -> b
$ [TextsError] -> TextsError
forall a. [a] -> a
head ([TextsError] -> TextsError) -> [TextsError] -> TextsError
forall a b. (a -> b) -> a -> b
$ [TextsError] -> [TextsError]
forall e. (ErrorPosition e, Ord (Pos e)) => [e] -> [e]
bestErrors [TextsError
e | Left TextsError
e <- [Either TextsError ((() -> url :- (), [Text]), MajorMinorPos)]
results])
[((url :- (), [Text]), MajorMinorPos)]
_ -> case ((((url :- (), [Text]), MajorMinorPos)
-> ((url :- (), [Text]), MajorMinorPos) -> Ordering)
-> [((url :- (), [Text]), MajorMinorPos)]
-> ((url :- (), [Text]), MajorMinorPos)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (MajorMinorPos -> MajorMinorPos -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (MajorMinorPos -> MajorMinorPos -> Ordering)
-> (((url :- (), [Text]), MajorMinorPos) -> MajorMinorPos)
-> ((url :- (), [Text]), MajorMinorPos)
-> ((url :- (), [Text]), MajorMinorPos)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((url :- (), [Text]), MajorMinorPos) -> MajorMinorPos
forall a b. (a, b) -> b
snd) [((url :- (), [Text]), MajorMinorPos)]
successes) of
(((url
u :- ()), [Text]
tok), MajorMinorPos
pos) ->
do let st' :: State [Text] ()
st' = State [Text] ()
st { statePos :: SourcePos
statePos = SourcePos -> Line -> SourcePos
setSourceColumn (SourcePos -> Line -> SourcePos
setSourceLine (State [Text] () -> SourcePos
forall s u. State s u -> SourcePos
statePos State [Text] ()
st) (Integer -> Line
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Line) -> Integer -> Line
forall a b. (a -> b) -> a -> b
$ MajorMinorPos -> Integer
major MajorMinorPos
pos)) (Integer -> Line
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Line) -> Integer -> Line
forall a b. (a -> b) -> a -> b
$ MajorMinorPos -> Integer
minor MajorMinorPos
pos)
, stateInput :: [Text]
stateInput = [Text] -> [Text]
trim [Text]
tok
}
State [Text] () -> ParsecT [Text] () Identity (State [Text] ())
forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State [Text] ()
st'
url -> URLParser url
forall (m :: * -> *) a. Monad m => a -> m a
return url
u
where
trim :: [Text] -> [Text]
trim [] = []
trim (Text
t:[Text]
ts) = if Text -> Bool
T.null Text
t then [Text]
ts else (Text
tText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
ts)
boomerangToPathSegments :: Boomerang TextsError [Text] () (url :- ()) -> (url -> [Text])
boomerangToPathSegments :: Boomerang TextsError [Text] () (url :- ()) -> url -> [Text]
boomerangToPathSegments Boomerang TextsError [Text] () (url :- ())
pp =
\url
url -> case [Text]
-> Boomerang TextsError [Text] () (url :- ())
-> url
-> Maybe [Text]
forall tok e a.
tok -> Boomerang e tok () (a :- ()) -> a -> Maybe tok
unparse1 [] Boomerang TextsError [Text] () (url :- ())
pp url
url of
Maybe [Text]
Nothing -> String -> [Text]
forall a. HasCallStack => String -> a
error (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String
"boomerangToPathSegments: could not convert url to [Text]"
(Just [Text]
txts) -> [Text]
txts