{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Okapi.HTTP.Request.Path (
    Path (..),
    ParseError (..),
    parser,
    printer,
    parseExact,
    segment_,
    segment,
    segments,
    raw,
    LitF (..),
    GPath (..),
    pathCodec,
) where

import Data.Bifunctor (first)
import Data.Int (Int16, Int32, Int64)
import Data.Kind (Type)
-- In the import of `Data.List.NonEmpty':
--   an item called `(:|)'
--   is exported, but it is a data constructor of
--   `NonEmpty'.
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NEL
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.UUID (UUID)
import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1, Selector (..), (:*:) (..))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Okapi.Tree (Failure, HasLeaf (..), Info (..), Leaf (..), Parser, Printer, Piece, Context, Tree (..))
import Okapi.Tree qualified as Tree
import Web.HttpApiData (parseUrlPiece, toUrlPiece)

-- $setup
-- >>> :set -XApplicativeDo
-- >>> import Okapi.Tree (printParse, printStable, int, integer, (=.))
-- >>> import Data.List.NonEmpty (NonEmpty((:|)))
-- >>> :{
-- let twoSegs = do
--       n <- fst =. segment "n" int
--       m <- snd =. segment "m" int
--       pure (n, m)
-- :}

data Path a where
    Seg_ :: Leaf Path a -> a -> Path ()
    Seg  :: Text -> Leaf Path a -> Path a
    Segs :: Leaf Path a -> Path (NonEmpty a)
    Raw  :: Path [Text]

data ParseError = ParseError deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show)

type instance Context  Path = [Text]
type instance Failure  Path = ParseError
type instance Piece  Path = Text

parser :: Tree Path i o -> Parser Path o
parser :: forall i o. Tree Path i o -> Parser Path o
parser = (forall a. Path a -> Parser Path a)
-> Tree Path i o
-> Context Path
-> (Either (Failure Path) o, Context Path)
forall (t :: * -> *) i o.
(forall a. t a -> Parser t a) -> Tree t i o -> Parser t o
Tree.parser Path a -> Parser Path a
forall a. Path a -> Parser Path a
alg
  where
    alg :: Path a -> Parser Path a
    alg :: forall a. Path a -> Parser Path a
alg (Seg_ Leaf Path a
vLeaf a
x) (Text
t : [Text]
ts)
        | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Leaf Path a
vLeaf.encode a
x = (a -> Either ParseError a
forall a b. b -> Either a b
Right (), [Text]
Context Path
ts)
        | Bool
otherwise            = (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ts)
    alg (Seg_ Leaf Path a
_ a
_) [] = (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, [])
    alg (Seg Text
_name Leaf Path a
vLeaf) (Text
t : [Text]
ts) = case Leaf Path a
vLeaf.decode Text
t of
        Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ts)
        Right a
v -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
v, [Text]
Context Path
ts)
    alg (Seg Text
_ Leaf Path a
_) [] = (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, [])
    alg (Segs Leaf Path a
vLeaf) Context Path
ts = case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Text]
Context Path
ts of
        Maybe (NonEmpty Text)
Nothing  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, [])
        Just NonEmpty Text
nel -> case (Text -> Either ParseError a) -> [Text] -> Either ParseError [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Leaf Path a
vLeaf.decode (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Text
nel) of
            Left ParseError
_   -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Path
ts)
            Right [a]
xs -> case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [a]
xs of
                Maybe (NonEmpty a)
Nothing   -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, [])
                Just NonEmpty a
nel' -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
NonEmpty a
nel', [])
    alg Path a
Raw Context Path
ts = (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Context Path
ts, [])

printer :: Tree Path i o -> Printer Path i
printer :: forall i o. Tree Path i o -> Printer Path i
printer = (forall a. Path a -> Printer Path a)
-> Tree Path i o -> i -> Context Path
forall (t :: * -> *) i o.
Monoid (Context t) =>
(forall a. t a -> Printer t a) -> Tree t i o -> Printer t i
Tree.printer Path a -> Printer Path a
forall a. Path a -> Printer Path a
alg
  where
    alg :: Path a -> Printer Path a
    alg :: forall a. Path a -> Printer Path a
alg (Seg_ Leaf Path a
vLeaf a
x) () = [Leaf Path a
vLeaf.encode a
x]
    alg (Seg Text
_name Leaf Path a
vLeaf) a
v = [Leaf Path a
vLeaf.encode a
v]
    alg (Segs Leaf Path a
vLeaf) a
nel = (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Leaf Path a
vLeaf.encode (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NEL.toList a
NonEmpty a
nel)
    alg Path a
Raw a
ts = a
Context Path
ts

parseExact :: Tree Path i o -> [Text] -> Either (Either ParseError [Text]) o
parseExact :: forall i o.
Tree Path i o -> [Text] -> Either (Either ParseError [Text]) o
parseExact Tree Path i o
c [Text]
ts = case Tree Path i o -> Parser Path o
forall i o. Tree Path i o -> Parser Path o
parser Tree Path i o
c [Text]
Context Path
ts of
    (Left Failure Path
e, Context Path
_)        -> Either ParseError [Text] -> Either (Either ParseError [Text]) o
forall a b. a -> Either a b
Left (ParseError -> Either ParseError [Text]
forall a b. a -> Either a b
Left Failure Path
ParseError
e)
    (Right o
a, [])      -> o -> Either (Either ParseError [Text]) o
forall a b. b -> Either a b
Right o
a
    (Right o
_, Context Path
ts')     -> Either ParseError [Text] -> Either (Either ParseError [Text]) o
forall a b. a -> Either a b
Left ([Text] -> Either ParseError [Text]
forall a b. b -> Either a b
Right [Text]
Context Path
ts')

-- | Match a fixed literal segment.
--
-- >>> printer (segment_ int 42) ()
-- ["42"]
-- >>> parser (segment_ int 42) ["42"]
-- (Right (),[])
-- >>> parser (segment_ int 42) ["99"]
-- (Left ParseError,["99"])
segment_ :: Leaf Path a -> a -> Tree Path () ()
segment_ :: forall a. Leaf Path a -> a -> Tree Path () ()
segment_ Leaf Path a
vLeaf a
x = (() -> ()) -> Tree Path () () -> Tree Path () ()
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (() -> () -> ()
forall a b. a -> b -> a
const ()) (Path () -> Tree Path () ()
forall (t :: * -> *) i. t i -> Tree t i i
Node (Leaf Path a -> a -> Path ()
forall a. Leaf Path a -> a -> Path ()
Seg_ Leaf Path a
vLeaf a
x))

-- | Parse and print a single typed path segment.
--
-- >>> printer (segment "id" int) (42 :: Int)
-- ["42"]
-- >>> parser (segment "id" int) ["42"]
-- (Right 42,[])
-- >>> parser (segment "id" int) ["hello"]
-- (Left ParseError,["hello"])
-- >>> parser (segment "id" int) []
-- (Left ParseError,[])
--
-- prop> printParse parser printer (segment "n" int) (x :: Int)
-- prop> printParse parser printer (segment "n" integer) x
-- prop> printStable parser printer (segment "n" int) (x :: Int)
segment :: Text -> Leaf Path a -> Tree Path a a
segment :: forall a. Text -> Leaf Path a -> Tree Path a a
segment Text
name Leaf Path a
vLeaf = Path a -> Tree Path a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (Text -> Leaf Path a -> Path a
forall a. Text -> Leaf Path a -> Path a
Seg Text
name Leaf Path a
vLeaf)

-- | Parse and print all remaining path segments as a non-empty list.
--
-- prop> printParse parser printer (segments int) (x :| xs)
-- prop> printStable parser printer (segments int) (x :| xs)
segments :: Leaf Path a -> Tree Path (NonEmpty a) (NonEmpty a)
segments :: forall a. Leaf Path a -> Tree Path (NonEmpty a) (NonEmpty a)
segments Leaf Path a
vLeaf = Path (NonEmpty a) -> Tree Path (NonEmpty a) (NonEmpty a)
forall (t :: * -> *) i. t i -> Tree t i i
Node (Leaf Path a -> Path (NonEmpty a)
forall a. Leaf Path a -> Path (NonEmpty a)
Segs Leaf Path a
vLeaf)

raw :: Tree Path [Text] [Text]
raw :: Tree Path [Text] [Text]
raw = Path [Text] -> Tree Path [Text] [Text]
forall (t :: * -> *) i. t i -> Tree t i i
Node Path [Text]
Raw

instance HasLeaf Path Int     where leaf :: Leaf Path Int
leaf = (Piece Path -> Either (Failure Path) Int)
-> (Int -> Piece Path) -> Info -> Leaf Path Int
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Int -> Either ParseError Int
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int -> Either ParseError Int)
-> (Text -> Either Text Int) -> Text -> Either ParseError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Int
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Int -> Text
Int -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Path Int16   where leaf :: Leaf Path Int16
leaf = (Piece Path -> Either (Failure Path) Int16)
-> (Int16 -> Piece Path) -> Info -> Leaf Path Int16
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int16 -> Either ParseError Int16
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int16 -> Either ParseError Int16)
-> (Text -> Either Text Int16) -> Text -> Either ParseError Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Int16
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Int16 -> Text
Int16 -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int32"))
instance HasLeaf Path Int32   where leaf :: Leaf Path Int32
leaf = (Piece Path -> Either (Failure Path) Int32)
-> (Int32 -> Piece Path) -> Info -> Leaf Path Int32
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int32 -> Either ParseError Int32
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int32 -> Either ParseError Int32)
-> (Text -> Either Text Int32) -> Text -> Either ParseError Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Int32
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Int32 -> Text
Int32 -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int32"))
instance HasLeaf Path Int64   where leaf :: Leaf Path Int64
leaf = (Piece Path -> Either (Failure Path) Int64)
-> (Int64 -> Piece Path) -> Info -> Leaf Path Int64
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int64 -> Either ParseError Int64
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int64 -> Either ParseError Int64)
-> (Text -> Either Text Int64) -> Text -> Either ParseError Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Int64
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Int64 -> Text
Int64 -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int64"))
instance HasLeaf Path Integer where leaf :: Leaf Path Integer
leaf = (Piece Path -> Either (Failure Path) Integer)
-> (Integer -> Piece Path) -> Info -> Leaf Path Integer
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Integer -> Either ParseError Integer
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Integer -> Either ParseError Integer)
-> (Text -> Either Text Integer)
-> Text
-> Either ParseError Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Integer
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Integer -> Text
Integer -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Path Text    where leaf :: Leaf Path Text
leaf = (Piece Path -> Either (Failure Path) Text)
-> (Text -> Piece Path) -> Info -> Leaf Path Text
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Text -> Either ParseError Text
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Text -> Either ParseError Text)
-> (Text -> Either Text Text) -> Text -> Either ParseError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Text
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) Text -> Text
Text -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Path UUID    where leaf :: Leaf Path UUID
leaf = (Piece Path -> Either (Failure Path) UUID)
-> (UUID -> Piece Path) -> Info -> Leaf Path UUID
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text UUID -> Either ParseError UUID
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 (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text UUID -> Either ParseError UUID)
-> (Text -> Either Text UUID) -> Text -> Either ParseError UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text UUID
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece) UUID -> Text
UUID -> Piece Path
forall a. ToHttpApiData a => a -> Text
toUrlPiece (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"uuid"))

data LitF (sym :: Symbol) = LitF deriving (LitF sym -> LitF sym -> Bool
(LitF sym -> LitF sym -> Bool)
-> (LitF sym -> LitF sym -> Bool) -> Eq (LitF sym)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (sym :: Symbol). LitF sym -> LitF sym -> Bool
$c== :: forall (sym :: Symbol). LitF sym -> LitF sym -> Bool
== :: LitF sym -> LitF sym -> Bool
$c/= :: forall (sym :: Symbol). LitF sym -> LitF sym -> Bool
/= :: LitF sym -> LitF sym -> Bool
Eq, Int -> LitF sym -> ShowS
[LitF sym] -> ShowS
LitF sym -> String
(Int -> LitF sym -> ShowS)
-> (LitF sym -> String) -> ([LitF sym] -> ShowS) -> Show (LitF sym)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (sym :: Symbol). Int -> LitF sym -> ShowS
forall (sym :: Symbol). [LitF sym] -> ShowS
forall (sym :: Symbol). LitF sym -> String
$cshowsPrec :: forall (sym :: Symbol). Int -> LitF sym -> ShowS
showsPrec :: Int -> LitF sym -> ShowS
$cshow :: forall (sym :: Symbol). LitF sym -> String
show :: LitF sym -> String
$cshowList :: forall (sym :: Symbol). [LitF sym] -> ShowS
showList :: [LitF sym] -> ShowS
Show)

class GPath (f :: Type -> Type) where
    gPathCodec :: Tree Path (f ()) (f ())

instance (GPath f) => GPath (D1 meta f) where
    gPathCodec :: Tree Path (D1 meta f ()) (D1 meta f ())
gPathCodec = (f () -> D1 meta f ())
-> Tree Path (D1 meta f ()) (f ())
-> Tree Path (D1 meta f ()) (D1 meta f ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap f () -> D1 meta f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Tree Path (D1 meta f ()) (f ())
 -> Tree Path (D1 meta f ()) (D1 meta f ()))
-> Tree Path (D1 meta f ()) (f ())
-> Tree Path (D1 meta f ()) (D1 meta f ())
forall a b. (a -> b) -> a -> b
$ (D1 meta f () -> f ())
-> Tree Path (f ()) (f ()) -> Tree Path (D1 meta f ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap D1 meta f () -> f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 Tree Path (f ()) (f ())
forall (f :: * -> *). GPath f => Tree Path (f ()) (f ())
gPathCodec

instance (GPath f) => GPath (C1 meta f) where
    gPathCodec :: Tree Path (C1 meta f ()) (C1 meta f ())
gPathCodec = (f () -> C1 meta f ())
-> Tree Path (C1 meta f ()) (f ())
-> Tree Path (C1 meta f ()) (C1 meta f ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap f () -> C1 meta f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Tree Path (C1 meta f ()) (f ())
 -> Tree Path (C1 meta f ()) (C1 meta f ()))
-> Tree Path (C1 meta f ()) (f ())
-> Tree Path (C1 meta f ()) (C1 meta f ())
forall a b. (a -> b) -> a -> b
$ (C1 meta f () -> f ())
-> Tree Path (f ()) (f ()) -> Tree Path (C1 meta f ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap C1 meta f () -> f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 Tree Path (f ()) (f ())
forall (f :: * -> *). GPath f => Tree Path (f ()) (f ())
gPathCodec

instance (GPath f, GPath g) => GPath (f :*: g) where
    gPathCodec :: Tree Path ((:*:) f g ()) ((:*:) f g ())
gPathCodec =
        Tree Path ((:*:) f g ()) (g () -> (:*:) f g ())
-> Tree Path ((:*:) f g ()) (g ())
-> Tree Path ((:*:) f g ()) ((:*:) f g ())
forall (t :: * -> *) i o1 o.
Tree t i (o1 -> o) -> Tree t i o1 -> Tree t i o
Apply
            ((f () -> g () -> (:*:) f g ())
-> Tree Path ((:*:) f g ()) (f ())
-> Tree Path ((:*:) f g ()) (g () -> (:*:) f g ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (\f ()
l g ()
r -> f ()
l f () -> g () -> (:*:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g ()
r) (((:*:) f g () -> f ())
-> Tree Path (f ()) (f ()) -> Tree Path ((:*:) f g ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (\(f ()
l :*: g ()
_) -> f ()
l) Tree Path (f ()) (f ())
forall (f :: * -> *). GPath f => Tree Path (f ()) (f ())
gPathCodec))
            (((:*:) f g () -> g ())
-> Tree Path (g ()) (g ()) -> Tree Path ((:*:) f g ()) (g ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (\(f ()
_ :*: g ()
r) -> g ()
r) Tree Path (g ()) (g ())
forall (f :: * -> *). GPath f => Tree Path (f ()) (f ())
gPathCodec)

instance {-# OVERLAPPING #-} (KnownSymbol sym) => GPath (S1 meta (Rec0 (LitF sym))) where
    gPathCodec :: Tree
  Path (S1 meta (Rec0 (LitF sym)) ()) (S1 meta (Rec0 (LitF sym)) ())
gPathCodec =
        let txt :: Text
txt = String -> Text
Text.pack (Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @sym))
         in (() -> S1 meta (Rec0 (LitF sym)) ())
-> Tree Path (S1 meta (Rec0 (LitF sym)) ()) ()
-> Tree
     Path (S1 meta (Rec0 (LitF sym)) ()) (S1 meta (Rec0 (LitF sym)) ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (\() -> Rec0 (LitF sym) () -> S1 meta (Rec0 (LitF sym)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (LitF sym -> Rec0 (LitF sym) ()
forall k i c (p :: k). c -> K1 i c p
K1 LitF sym
forall (sym :: Symbol). LitF sym
LitF)) (Tree Path (S1 meta (Rec0 (LitF sym)) ()) ()
 -> Tree
      Path (S1 meta (Rec0 (LitF sym)) ()) (S1 meta (Rec0 (LitF sym)) ()))
-> Tree Path (S1 meta (Rec0 (LitF sym)) ()) ()
-> Tree
     Path (S1 meta (Rec0 (LitF sym)) ()) (S1 meta (Rec0 (LitF sym)) ())
forall a b. (a -> b) -> a -> b
$ (S1 meta (Rec0 (LitF sym)) () -> ())
-> Tree Path () () -> Tree Path (S1 meta (Rec0 (LitF sym)) ()) ()
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (() -> S1 meta (Rec0 (LitF sym)) () -> ()
forall a b. a -> b -> a
const ()) (Tree Path () () -> Tree Path (S1 meta (Rec0 (LitF sym)) ()) ())
-> Tree Path () () -> Tree Path (S1 meta (Rec0 (LitF sym)) ()) ()
forall a b. (a -> b) -> a -> b
$ Path () -> Tree Path () ()
forall (t :: * -> *) i. t i -> Tree t i i
Node (Leaf Path Text -> Text -> Path ()
forall a. Leaf Path a -> a -> Path ()
Seg_ (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Path @Text) Text
txt)

instance (Selector meta, HasLeaf Path a) => GPath (S1 meta (Rec0 a)) where
    gPathCodec :: Tree Path (S1 meta (Rec0 a) ()) (S1 meta (Rec0 a) ())
gPathCodec =
        let name :: Text
name = String -> Text
Text.pack (S1 meta (Rec0 a) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t meta f a -> String
selName (S1 meta (Rec0 a) ()
forall a. HasCallStack => a
undefined :: S1 meta (Rec0 a) ()))
         in (a -> S1 meta (Rec0 a) ())
-> Tree Path (S1 meta (Rec0 a) ()) a
-> Tree Path (S1 meta (Rec0 a) ()) (S1 meta (Rec0 a) ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (Rec0 a () -> S1 meta (Rec0 a) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 a () -> S1 meta (Rec0 a) ())
-> (a -> Rec0 a ()) -> a -> S1 meta (Rec0 a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a ()
forall k i c (p :: k). c -> K1 i c p
K1) (Tree Path (S1 meta (Rec0 a) ()) a
 -> Tree Path (S1 meta (Rec0 a) ()) (S1 meta (Rec0 a) ()))
-> Tree Path (S1 meta (Rec0 a) ()) a
-> Tree Path (S1 meta (Rec0 a) ()) (S1 meta (Rec0 a) ())
forall a b. (a -> b) -> a -> b
$ (S1 meta (Rec0 a) () -> a)
-> Tree Path a a -> Tree Path (S1 meta (Rec0 a) ()) a
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (Rec0 a () -> a
forall k i c (p :: k). K1 i c p -> c
unK1 (Rec0 a () -> a)
-> (S1 meta (Rec0 a) () -> Rec0 a ()) -> S1 meta (Rec0 a) () -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 meta (Rec0 a) () -> Rec0 a ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (Tree Path a a -> Tree Path (S1 meta (Rec0 a) ()) a)
-> Tree Path a a -> Tree Path (S1 meta (Rec0 a) ()) a
forall a b. (a -> b) -> a -> b
$ Path a -> Tree Path a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (Text -> Leaf Path a -> Path a
forall a. Text -> Leaf Path a -> Path a
Seg Text
name (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Path @a))

pathCodec :: forall a. (Generic a, GPath (Rep a)) => Tree Path a a
pathCodec :: forall a. (Generic a, GPath (Rep a)) => Tree Path a a
pathCodec = (Rep a () -> a) -> Tree Path a (Rep a ()) -> Tree Path a a
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (forall a x. Generic a => Rep a x -> a
to @a) (Tree Path a (Rep a ()) -> Tree Path a a)
-> Tree Path a (Rep a ()) -> Tree Path a a
forall a b. (a -> b) -> a -> b
$ (a -> Rep a ())
-> Tree Path (Rep a ()) (Rep a ()) -> Tree Path a (Rep a ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (forall a x. Generic a => a -> Rep a x
from @a) Tree Path (Rep a ()) (Rep a ())
forall (f :: * -> *). GPath f => Tree Path (f ()) (f ())
gPathCodec

-- $combined
-- >>> parser twoSegs ["42", "99", "extra"]
-- (Right (42,99),["extra"])
--
-- prop> printParse parser printer twoSegs (xy :: (Int, Int))
-- prop> printStable parser printer twoSegs (xy :: (Int, Int))