module Okapi.Tree (
    Context,
    Failure,
    Piece,
    Parser,
    Printer,
    Info (..),
    Leaf (..),
    HasLeaf (..),
    int,
    int16,
    int32,
    int64,
    integer,
    bool,
    float,
    double,
    scientific,
    text,
    day,
    localTime,
    utcTime,
    timeOfDay,
    uuid,
    Tree (..),
    SymTree,
    (=.),
    cost,
    parser,
    printer,
    printParse,
    printStable,
) where

import Data.Int (Int16, Int32, Int64)
import Data.Kind (Type)
import Data.Profunctor
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (Day, LocalTime, TimeOfDay, UTCTime)
import Data.UUID (UUID)

-- ── Leaf ─────────────────────────────────────────────────────────────────────

type Context :: (Type -> Type) -> Type
type family Context t

type Failure :: (Type -> Type) -> Type
type family Failure t

type Piece :: (Type -> Type) -> Type
type family Piece t

type Parser t a = Context t -> (Either (Failure t) a, Context t)
type Printer t a = a -> Context t

data Info = Info
    { Info -> Text
typeName :: Text
    , Info -> Maybe Text
format   :: Maybe Text
    }
    deriving (Info -> Info -> Bool
(Info -> Info -> Bool) -> (Info -> Info -> Bool) -> Eq Info
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Info -> Info -> Bool
== :: Info -> Info -> Bool
$c/= :: Info -> Info -> Bool
/= :: Info -> Info -> Bool
Eq, Int -> Info -> ShowS
[Info] -> ShowS
Info -> String
(Int -> Info -> ShowS)
-> (Info -> String) -> ([Info] -> ShowS) -> Show Info
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Info -> ShowS
showsPrec :: Int -> Info -> ShowS
$cshow :: Info -> String
show :: Info -> String
$cshowList :: [Info] -> ShowS
showList :: [Info] -> ShowS
Show)

type Leaf :: (Type -> Type) -> Type -> Type
data Leaf t a = Leaf
    { forall (t :: * -> *) a. Leaf t a -> Piece t -> Either (Failure t) a
decode :: Piece t -> Either (Failure t) a
    , forall (t :: * -> *) a. Leaf t a -> a -> Piece t
encode :: a -> Piece t
    , forall (t :: * -> *) a. Leaf t a -> Info
info   :: Info
    }

class HasLeaf t a where
    leaf :: Leaf t a

int :: (HasLeaf t Int) => Leaf t Int
int :: forall (t :: * -> *). HasLeaf t Int => Leaf t Int
int = Leaf t Int
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

int16 :: (HasLeaf t Int16) => Leaf t Int16
int16 :: forall (t :: * -> *). HasLeaf t Int16 => Leaf t Int16
int16 = Leaf t Int16
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

int32 :: (HasLeaf t Int32) => Leaf t Int32
int32 :: forall (t :: * -> *). HasLeaf t Int32 => Leaf t Int32
int32 = Leaf t Int32
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

int64 :: (HasLeaf t Int64) => Leaf t Int64
int64 :: forall (t :: * -> *). HasLeaf t Int64 => Leaf t Int64
int64 = Leaf t Int64
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

integer :: (HasLeaf t Integer) => Leaf t Integer
integer :: forall (t :: * -> *). HasLeaf t Integer => Leaf t Integer
integer = Leaf t Integer
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

bool :: (HasLeaf t Bool) => Leaf t Bool
bool :: forall (t :: * -> *). HasLeaf t Bool => Leaf t Bool
bool = Leaf t Bool
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

float :: (HasLeaf t Float) => Leaf t Float
float :: forall (t :: * -> *). HasLeaf t Float => Leaf t Float
float = Leaf t Float
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

double :: (HasLeaf t Double) => Leaf t Double
double :: forall (t :: * -> *). HasLeaf t Double => Leaf t Double
double = Leaf t Double
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

scientific :: (HasLeaf t Scientific) => Leaf t Scientific
scientific :: forall (t :: * -> *). HasLeaf t Scientific => Leaf t Scientific
scientific = Leaf t Scientific
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

text :: (HasLeaf t Text) => Leaf t Text
text :: forall (t :: * -> *). HasLeaf t Text => Leaf t Text
text = Leaf t Text
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

day :: (HasLeaf t Day) => Leaf t Day
day :: forall (t :: * -> *). HasLeaf t Day => Leaf t Day
day = Leaf t Day
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

localTime :: (HasLeaf t LocalTime) => Leaf t LocalTime
localTime :: forall (t :: * -> *). HasLeaf t LocalTime => Leaf t LocalTime
localTime = Leaf t LocalTime
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

utcTime :: (HasLeaf t UTCTime) => Leaf t UTCTime
utcTime :: forall (t :: * -> *). HasLeaf t UTCTime => Leaf t UTCTime
utcTime = Leaf t UTCTime
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

timeOfDay :: (HasLeaf t TimeOfDay) => Leaf t TimeOfDay
timeOfDay :: forall (t :: * -> *). HasLeaf t TimeOfDay => Leaf t TimeOfDay
timeOfDay = Leaf t TimeOfDay
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

uuid :: (HasLeaf t UUID) => Leaf t UUID
uuid :: forall (t :: * -> *). HasLeaf t UUID => Leaf t UUID
uuid = Leaf t UUID
forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf

-- ── Tree ─────────────────────────────────────────────────────────────────────

type Tree :: (Type -> Type) -> Type -> Type -> Type
data Tree t i o where
    FMap  :: (o -> o') -> Tree t i o -> Tree t i o'
    LMap  :: (i -> i') -> Tree t i' o -> Tree t i o
    Pure  :: o -> Tree t i o
    Apply :: Tree t i (o -> o') -> Tree t i o -> Tree t i o'
    Node  :: t a -> Tree t a a

-- | A symmetrical @Tree t i o@ where @i ~ o@.
type SymTree t a = Tree t a a

instance Functor (Tree t i) where
    fmap :: forall a b. (a -> b) -> Tree t i a -> Tree t i b
fmap = (a -> b) -> Tree t i a -> Tree t i b
forall i' o' (t :: * -> *) i.
(i' -> o') -> Tree t i i' -> Tree t i o'
FMap

instance Applicative (Tree t i) where
    pure :: forall a. a -> Tree t i a
pure = a -> Tree t i a
forall o (t :: * -> *) i. o -> Tree t i o
Pure
    <*> :: forall a b. Tree t i (a -> b) -> Tree t i a -> Tree t i b
(<*>) = Tree t i (a -> b) -> Tree t i a -> Tree t i b
forall (t :: * -> *) i a b.
Tree t i (a -> b) -> Tree t i a -> Tree t i b
Apply

instance Profunctor (Tree t) where
    rmap :: forall b c a. (b -> c) -> Tree t a b -> Tree t a c
rmap = (b -> c) -> Tree t a b -> Tree t a c
forall i' o' (t :: * -> *) i.
(i' -> o') -> Tree t i i' -> Tree t i o'
FMap
    lmap :: forall a b c. (a -> b) -> Tree t b c -> Tree t a c
lmap = (a -> b) -> Tree t b c -> Tree t a c
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap

(=.) :: (Profunctor p) => (a -> b) -> p b c -> p a c
=. :: forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
(=.) = (a -> b) -> p b c -> p a c
forall a b c. (a -> b) -> p b c -> p a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap
infixr 5 =.

cost :: Tree t i o -> Int
cost :: forall (t :: * -> *) i o. Tree t i o -> Int
cost = \case
    FMap o -> o
_ Tree t i o
c   -> Tree t i o -> Int
forall (t :: * -> *) i o. Tree t i o -> Int
cost Tree t i o
c
    LMap i -> i'
_ Tree t i' o
c   -> Tree t i' o -> Int
forall (t :: * -> *) i o. Tree t i o -> Int
cost Tree t i' o
c
    Pure o
_     -> Int
0
    Apply Tree t i (o -> o)
c Tree t i o
c' -> Tree t i (o -> o) -> Int
forall (t :: * -> *) i o. Tree t i o -> Int
cost Tree t i (o -> o)
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Tree t i o -> Int
forall (t :: * -> *) i o. Tree t i o -> Int
cost Tree t i o
c'
    Node t i
_     -> Int
1

parser ::
    forall t i o.
    (forall a. t a -> Parser t a) ->
    Tree t i o ->
    Parser t o
parser :: forall (t :: * -> *) i o.
(forall a. t a -> Parser t a) -> Tree t i o -> Parser t o
parser forall a. t a -> Parser t a
alg = Tree t i o -> Parser t o
forall i' o'. Tree t i' o' -> Parser t o'
go
  where
    go :: forall i' o'. Tree t i' o' -> Parser t o'
    go :: forall i' o'. Tree t i' o' -> Parser t o'
go (Pure o'
x) Context t
s = (o' -> Either (Failure t) o'
forall a b. b -> Either a b
Right o'
x, Context t
s)
    go (FMap o -> o'
f Tree t i' o
c) Context t
s = case Tree t i' o -> Parser t o
forall i' o'. Tree t i' o' -> Parser t o'
go Tree t i' o
c Context t
s of
        (Left Failure t
e, Context t
s')  -> (Failure t -> Either (Failure t) o'
forall a b. a -> Either a b
Left Failure t
e, Context t
s')
        (Right o
x, Context t
s') -> (o' -> Either (Failure t) o'
forall a b. b -> Either a b
Right (o -> o'
f o
x), Context t
s')
    go (LMap i' -> i'
_ Tree t i' o'
c) Context t
s = Tree t i' o' -> Parser t o'
forall i' o'. Tree t i' o' -> Parser t o'
go Tree t i' o'
c Context t
s
    go (Apply Tree t i' (o -> o')
cf Tree t i' o
cx) Context t
s = case Tree t i' (o -> o') -> Parser t (o -> o')
forall i' o'. Tree t i' o' -> Parser t o'
go Tree t i' (o -> o')
cf Context t
s of
        (Left Failure t
e, Context t
s1)  -> (Failure t -> Either (Failure t) o'
forall a b. a -> Either a b
Left Failure t
e, Context t
s1)
        (Right o -> o'
f, Context t
s1) -> case Tree t i' o -> Parser t o
forall i' o'. Tree t i' o' -> Parser t o'
go Tree t i' o
cx Context t
s1 of
            (Left Failure t
e, Context t
s2)  -> (Failure t -> Either (Failure t) o'
forall a b. a -> Either a b
Left Failure t
e, Context t
s2)
            (Right o
x, Context t
s2) -> (o' -> Either (Failure t) o'
forall a b. b -> Either a b
Right (o -> o'
f o
x), Context t
s2)
    go (Node t i'
t) Context t
s = t o' -> Parser t o'
forall a. t a -> Parser t a
alg t i'
t o'
t Context t
s

printer ::
    forall t i o.
    (Monoid (Context t)) =>
    (forall a. t a -> Printer t a) ->
    Tree t i o ->
    Printer t i
printer :: forall (t :: * -> *) i o.
Monoid (Context t) =>
(forall a. t a -> Printer t a) -> Tree t i o -> Printer t i
printer forall a. t a -> Printer t a
alg = Tree t i o -> Printer t i
forall i' o'. Tree t i' o' -> Printer t i'
go
  where
    go :: forall i' o'. Tree t i' o' -> Printer t i'
    go :: forall i' o'. Tree t i' o' -> Printer t i'
go (Pure o'
_) i'
_      = Context t
forall a. Monoid a => a
mempty
    go (FMap o -> o'
_ Tree t i' o
c) i'
i    = Tree t i' o -> Printer t i'
forall i' o'. Tree t i' o' -> Printer t i'
go Tree t i' o
c i'
i
    go (LMap i' -> i'
f Tree t i' o'
c) i'
i    = Tree t i' o' -> Printer t i'
forall i' o'. Tree t i' o' -> Printer t i'
go Tree t i' o'
c (i' -> i'
f i'
i)
    go (Apply Tree t i' (o -> o')
cf Tree t i' o
cx) i'
i = Tree t i' (o -> o') -> Printer t i'
forall i' o'. Tree t i' o' -> Printer t i'
go Tree t i' (o -> o')
cf i'
i Context t -> Context t -> Context t
forall a. Semigroup a => a -> a -> a
<> Tree t i' o -> Printer t i'
forall i' o'. Tree t i' o' -> Printer t i'
go Tree t i' o
cx i'
i
    go (Node t i'
t) i'
i      = t i' -> Printer t i'
forall a. t a -> Printer t a
alg t i'
t i'
i

printParse ::
    (Eq a, Eq (Failure t), Eq (Context t), Monoid (Context t)) =>
    (SymTree t a -> Parser t a) ->
    (SymTree t a -> Printer t a) ->
    SymTree t a -> a -> Bool
printParse :: forall a (t :: * -> *).
(Eq a, Eq (Failure t), Eq (Context t), Monoid (Context t)) =>
(SymTree t a -> Parser t a)
-> (SymTree t a -> Printer t a) -> SymTree t a -> a -> Bool
printParse SymTree t a -> Parser t a
p SymTree t a -> Printer t a
q SymTree t a
c a
x = SymTree t a -> Parser t a
p SymTree t a
c (SymTree t a -> Printer t a
q SymTree t a
c a
x) (Either (Failure t) a, Context t)
-> (Either (Failure t) a, Context t) -> Bool
forall a. Eq a => a -> a -> Bool
== (a -> Either (Failure t) a
forall a b. b -> Either a b
Right a
x, Context t
forall a. Monoid a => a
mempty)

printStable ::
    (Eq (Context t), Monoid (Context t)) =>
    (SymTree t a -> Parser t a) ->
    (SymTree t a -> Printer t a) ->
    SymTree t a -> a -> Bool
printStable :: forall (t :: * -> *) a.
(Eq (Context t), Monoid (Context t)) =>
(SymTree t a -> Parser t a)
-> (SymTree t a -> Printer t a) -> SymTree t a -> a -> Bool
printStable SymTree t a -> Parser t a
p SymTree t a -> Printer t a
q SymTree t a
c a
x = case SymTree t a -> Parser t a
p SymTree t a
c (SymTree t a -> Printer t a
q SymTree t a
c a
x) of
    (Right a
x', Context t
_) -> SymTree t a -> Printer t a
q SymTree t a
c a
x' Context t -> Context t -> Bool
forall a. Eq a => a -> a -> Bool
== SymTree t a -> Printer t a
q SymTree t a
c a
x
    (Either (Failure t) a, Context t)
_             -> Bool
False