{-# 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 :: forall url a.
((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 { 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 forall e r. Boomerang e [Text] () (r :- ()) -> r -> Maybe [Text]
unparseTexts Router () (url :- ())
r url
url of
Maybe [Text]
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"formatPathSegments failed to produce a url"
(Just [Text]
ps) -> ([Text]
ps, [])
, parsePathSegments :: [Text] -> Either [Char] url
parsePathSegments = \[Text]
paths -> forall {a} {b} {b}. (a -> b) -> Either a b -> Either b b
mapLeft (forall {a}. Show a => a -> TextsError -> [Char]
showErrors [Text]
paths) (forall r.
Boomerang TextsError [Text] () (r :- ())
-> [Text] -> Either TextsError r
parseTexts Router () (url :- ())
r [Text]
paths)
}
where
mapLeft :: (a -> b) -> Either a b -> Either b b
mapLeft a -> b
f = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) forall a b. b -> Either a b
Right
showErrors :: a -> TextsError -> [Char]
showErrors a
paths TextsError
err = (forall pos. (pos -> [Char]) -> ParserError pos -> [Char]
showParserError MajorMinorPos -> [Char]
showPos TextsError
err) forall a. [a] -> [a] -> [a]
++ [Char]
" while parsing " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
paths
showPos :: MajorMinorPos -> [Char]
showPos (MajorMinorPos Integer
s Integer
c) = [Char]
"path segment " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Integer
s forall a. Num a => a -> a -> a
+ Integer
1) forall a. [a] -> [a] -> [a]
++ [Char]
", character " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
c
boomerangSiteRouteT :: (url -> RouteT url m a)
-> Router () (url :- ())
-> Site url (m a)
boomerangSiteRouteT :: forall url (m :: * -> *) a.
(url -> RouteT url m a) -> Router () (url :- ()) -> Site url (m a)
boomerangSiteRouteT url -> RouteT url m a
handler Router () (url :- ())
router = forall url a.
((url -> [(Text, Maybe Text)] -> Text) -> url -> a)
-> Router () (url :- ()) -> Site url a
boomerangSite (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT 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 :: forall url.
Boomerang TextsError [Text] () (url :- ()) -> URLParser url
boomerangFromPathSegments (Boomerang Parser TextsError [Text] (() -> url :- ())
prs (url :- ()) -> [([Text] -> [Text], ())]
_) =
do State [Text] ()
st <- forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
let results :: [Either TextsError ((() -> url :- (), [Text]), Pos TextsError)]
results = forall e tok a.
Parser e tok a -> tok -> Pos e -> [Either e ((a, tok), Pos e)]
runParser Parser TextsError [Text] (() -> url :- ())
prs (forall s u. State s u -> s
stateInput State [Text] ()
st) (Integer -> Integer -> MajorMinorPos
MajorMinorPos (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
sourceLine (forall s u. State s u -> SourcePos
statePos State [Text] ()
st)) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ SourcePos -> Line
sourceColumn (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
[] -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall pos. (pos -> [Char]) -> ParserError pos -> [Char]
showParserError (forall a b. a -> b -> a
const [Char]
"") forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ 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 (forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 (forall s u. State s u -> SourcePos
statePos State [Text] ()
st) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ MajorMinorPos -> Integer
major MajorMinorPos
pos)) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ MajorMinorPos -> Integer
minor MajorMinorPos
pos)
, stateInput :: [Text]
stateInput = [Text] -> [Text]
trim [Text]
tok
}
forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State [Text] ()
st'
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
tforall a. a -> [a] -> [a]
:[Text]
ts)
boomerangToPathSegments :: Boomerang TextsError [Text] () (url :- ()) -> (url -> [Text])
boomerangToPathSegments :: forall url.
Boomerang TextsError [Text] () (url :- ()) -> url -> [Text]
boomerangToPathSegments Boomerang TextsError [Text] () (url :- ())
pp =
\url
url -> case forall tok e a.
tok -> Boomerang e tok () (a :- ()) -> a -> Maybe tok
unparse1 [] Boomerang TextsError [Text] () (url :- ())
pp url
url of
Maybe [Text]
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"boomerangToPathSegments: could not convert url to [Text]"
(Just [Text]
txts) -> [Text]
txts