module URLT.Regular where
import Control.Applicative
import Control.Applicative.Error (Failing(Failure, Success))
import Control.Monad.Consumer (Consumer(Consumer), next, runConsumer)
import Control.Monad(MonadPlus(mzero, mplus), ap)
import Data.Char (toLower)
import Generics.Regular
import URLT.TH (AsURL(fromURLC, toURLS))
class GToURL f where
gtoURLS :: f a -> ShowS
gfromURLC :: Consumer String (Failing (f a))
instance AsURL a => GToURL (K a) where
gtoURLS (K a) = toURLS a
gfromURLC = fmap (fmap K) $ fromURLC
instance (GToURL f, GToURL g) => GToURL (f :+: g) where
gtoURLS (L x) = gtoURLS x
gtoURLS (R y) = gtoURLS y
gfromURLC = let urlLeft = fmap (fmap L) $ gfromURLC
urlRight = fmap (fmap R) $ gfromURLC
in urlLeft `combine` urlRight
where
combine :: Consumer String (Failing a) -> Consumer String (Failing a) -> Consumer String (Failing a)
combine (Consumer f) (Consumer g) =
Consumer $ \c ->
case f c of
r@(Success a, _) -> r
(Failure errs1, _) ->
case g c of
r@(Success a, _) -> r
(Failure errs2, _) -> (Failure (errs1 ++ errs2), c)
instance GToURL U where
gtoURLS U = id
gfromURLC =
do m <- next
case m of
Nothing -> return (Success U)
(Just str) -> return (Failure ["Excepted end of input, but got: " ++ str])
instance GToURL f => GToURL (S s f) where
gtoURLS (S x) = gtoURLS x
gfromURLC = fmap (fmap S) gfromURLC
instance forall c f. (Constructor c, GToURL f) => GToURL (C c f) where
gtoURLS c@(C x) = showString (lower $ conName c) . showString "/" . gtoURLS x
gfromURLC = let constr = undefined :: C c f r
name = conName constr
in do mx <- next
case mx of
Nothing -> return (Failure ["Excepted '" ++ lower name ++ "' but got end of input."])
(Just x) ->
if (lower x == lower name)
then fmap (fmap C) $ gfromURLC
else return (Failure ["Excepted '" ++ lower name ++ "' but got '" ++ lower x ++ "'"])
lower = map toLower