{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Web.Routing.Combinators where

import Data.HVect
import Data.String
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Web.HttpApiData
import Web.Routing.SafeRouting

data PathState = Open | Closed

data Path (as :: [*]) (pathState :: PathState) where
  Empty :: Path '[] 'Open
  StaticCons :: T.Text -> Path as ps -> Path as ps
  VarCons :: (FromHttpApiData a, Typeable a) => Path as ps -> Path (a ': as) ps
  Wildcard :: Path as 'Open -> Path (T.Text ': as) 'Closed

toInternalPath :: Path as pathState -> PathInternal as
toInternalPath :: Path as pathState -> PathInternal as
toInternalPath Path as pathState
Empty = PathInternal as
PathInternal '[]
PI_Empty
toInternalPath (StaticCons Text
t Path as pathState
p) = Text -> PathInternal as -> PathInternal as
forall (as :: [*]). Text -> PathInternal as -> PathInternal as
PI_StaticCons Text
t (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (VarCons Path as pathState
p) = PathInternal as -> PathInternal (a : as)
forall a (as :: [*]).
(FromHttpApiData a, Typeable a) =>
PathInternal as -> PathInternal (a : as)
PI_VarCons (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (Wildcard Path as 'Open
p) = PathInternal as -> PathInternal (Text : as)
forall (as :: [*]). PathInternal as -> PathInternal (Text : as)
PI_Wildcard (Path as 'Open -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as 'Open
p)

type Var a = Path (a ': '[]) 'Open

-- | A variant of 'Either' with a 'FromHttpApiData' definition that tries both branches without a prefix.
-- Useful to define routes with 'var's that should work with different types.
data AltVar a b = AvLeft a | AvRight b
  deriving (Int -> AltVar a b -> ShowS
[AltVar a b] -> ShowS
AltVar a b -> String
(Int -> AltVar a b -> ShowS)
-> (AltVar a b -> String)
-> ([AltVar a b] -> ShowS)
-> Show (AltVar a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> AltVar a b -> ShowS
forall a b. (Show a, Show b) => [AltVar a b] -> ShowS
forall a b. (Show a, Show b) => AltVar a b -> String
showList :: [AltVar a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [AltVar a b] -> ShowS
show :: AltVar a b -> String
$cshow :: forall a b. (Show a, Show b) => AltVar a b -> String
showsPrec :: Int -> AltVar a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> AltVar a b -> ShowS
Show, AltVar a b -> AltVar a b -> Bool
(AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool) -> Eq (AltVar a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
/= :: AltVar a b -> AltVar a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
== :: AltVar a b -> AltVar a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => AltVar a b -> AltVar a b -> Bool
Eq, ReadPrec [AltVar a b]
ReadPrec (AltVar a b)
Int -> ReadS (AltVar a b)
ReadS [AltVar a b]
(Int -> ReadS (AltVar a b))
-> ReadS [AltVar a b]
-> ReadPrec (AltVar a b)
-> ReadPrec [AltVar a b]
-> Read (AltVar a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [AltVar a b]
forall a b. (Read a, Read b) => ReadPrec (AltVar a b)
forall a b. (Read a, Read b) => Int -> ReadS (AltVar a b)
forall a b. (Read a, Read b) => ReadS [AltVar a b]
readListPrec :: ReadPrec [AltVar a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [AltVar a b]
readPrec :: ReadPrec (AltVar a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (AltVar a b)
readList :: ReadS [AltVar a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [AltVar a b]
readsPrec :: Int -> ReadS (AltVar a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (AltVar a b)
Read, Eq (AltVar a b)
Eq (AltVar a b)
-> (AltVar a b -> AltVar a b -> Ordering)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> Bool)
-> (AltVar a b -> AltVar a b -> AltVar a b)
-> (AltVar a b -> AltVar a b -> AltVar a b)
-> Ord (AltVar a b)
AltVar a b -> AltVar a b -> Bool
AltVar a b -> AltVar a b -> Ordering
AltVar a b -> AltVar a b -> AltVar a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. (Ord a, Ord b) => Eq (AltVar a b)
forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Ordering
forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
min :: AltVar a b -> AltVar a b -> AltVar a b
$cmin :: forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
max :: AltVar a b -> AltVar a b -> AltVar a b
$cmax :: forall a b.
(Ord a, Ord b) =>
AltVar a b -> AltVar a b -> AltVar a b
>= :: AltVar a b -> AltVar a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
> :: AltVar a b -> AltVar a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
<= :: AltVar a b -> AltVar a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
< :: AltVar a b -> AltVar a b -> Bool
$c< :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Bool
compare :: AltVar a b -> AltVar a b -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => AltVar a b -> AltVar a b -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (AltVar a b)
Ord)

instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (AltVar a b) where
  parseUrlPiece :: Text -> Either Text (AltVar a b)
parseUrlPiece Text
val =
    case Text -> Either Text a
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
val of
      Left Text
err ->
        case Text -> Either Text b
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
val of
          Left Text
err2 -> Text -> Either Text (AltVar a b)
forall a b. a -> Either a b
Left (Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err2)
          Right b
ok -> AltVar a b -> Either Text (AltVar a b)
forall a b. b -> Either a b
Right (b -> AltVar a b
forall a b. b -> AltVar a b
AvRight b
ok)
      Right a
ok -> AltVar a b -> Either Text (AltVar a b)
forall a b. b -> Either a b
Right (a -> AltVar a b
forall a b. a -> AltVar a b
AvLeft a
ok)

-- | A route parameter
var :: (Typeable a, FromHttpApiData a) => Path (a ': '[]) 'Open
var :: Path '[a] 'Open
var = Path '[] 'Open -> Path '[a] 'Open
forall a (as :: [*]) (ps :: PathState).
(FromHttpApiData a, Typeable a) =>
Path as ps -> Path (a : as) ps
VarCons Path '[] 'Open
Empty

-- | A static route piece
static :: String -> Path '[] 'Open
static :: String -> Path '[] 'Open
static String
s =
  let pieces :: [Text]
pieces = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
   in (Text -> Path '[] 'Open -> Path '[] 'Open)
-> Path '[] 'Open -> [Text] -> Path '[] 'Open
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Path '[] 'Open -> Path '[] 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Path '[] 'Open
Empty [Text]
pieces

instance (a ~ '[], pathState ~ 'Open) => IsString (Path a pathState) where
  fromString :: String -> Path a pathState
fromString = String -> Path a pathState
String -> Path '[] 'Open
static

-- | The root of a path piece. Use to define a handler for "/"
root :: Path '[] 'Open
root :: Path '[] 'Open
root = Path '[] 'Open
Empty

-- | Matches the rest of the route. Should be the last part of the path.
wildcard :: Path '[T.Text] 'Closed
wildcard :: Path '[Text] 'Closed
wildcard = Path '[] 'Open -> Path '[Text] 'Closed
forall (as :: [*]). Path as 'Open -> Path (Text : as) 'Closed
Wildcard Path '[] 'Open
Empty

(</>) :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
(</>) Path as 'Open
Empty Path bs ps2
xs = Path bs ps2
Path (Append as bs) ps2
xs
(</>) (StaticCons Text
pathPiece Path as 'Open
xs) Path bs ps2
ys = Text -> Path (Append as bs) ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
pathPiece (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps2 :: PathState).
Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> Path bs ps2
ys)
(</>) (VarCons Path as 'Open
xs) Path bs ps2
ys = Path (Append as bs) ps2 -> Path (a : Append as bs) ps2
forall a (as :: [*]) (ps :: PathState).
(FromHttpApiData a, Typeable a) =>
Path as ps -> Path (a : as) ps
VarCons (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps2 :: PathState).
Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> Path bs ps2
ys)

pathToRep :: Path as ps -> Rep as
pathToRep :: Path as ps -> Rep as
pathToRep Path as ps
Empty = Rep as
Rep '[]
RNil
pathToRep (StaticCons Text
_ Path as ps
p) = Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p
pathToRep (VarCons Path as ps
p) = Rep as -> Rep (a : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p)
pathToRep (Wildcard Path as 'Open
p) = Rep as -> Rep (Text : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as 'Open -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as 'Open
p)

renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> T.Text
renderRoute :: Path as 'Open -> HVect as -> Text
renderRoute Path as 'Open
p = [Text] -> Text
combineRoutePieces ([Text] -> Text) -> (HVect as -> [Text]) -> HVect as -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
p

renderRoute' :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> [T.Text]
renderRoute' :: Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
Empty HVect as
_ = []
renderRoute' (StaticCons Text
pathPiece Path as 'Open
pathXs) HVect as
paramXs =
  (Text
pathPiece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
pathXs HVect as
paramXs)
renderRoute' (VarCons Path as 'Open
pathXs) (t
val :&: HVect ts1
paramXs) =
  (t -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece t
val Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
pathXs HVect as
HVect ts1
paramXs)

#if __GLASGOW_HASKELL__ < 800
renderRoute' _ _ =
    error "This will never happen."
#endif