{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Instances for 'Data.Row.Records.Rec' and 'Data.Row.Variants.Var' types
module Data.Row.Extras(
      JsonRec(..)
    , JsonVar(..)
    , namedBranchFromJSON
    , type (.\\)
    ) where

import Data.Aeson (FromJSON, ToJSON, (.:), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Row hiding (type (.\\))
import Data.Row.Internal hiding (type (.\\))
import Data.Row.Records qualified as Records
import Data.Row.Variants qualified as Variants
import Data.Text (Text)
import GHC.TypeLits hiding (Text)

newtype JsonVar s = JsonVar { JsonVar s -> Var s
unJsonVar :: Var s }

instance (AllUniqueLabels s, Forall s FromJSON) => FromJSON (JsonVar s) where
    parseJSON :: Value -> Parser (JsonVar s)
parseJSON Value
vl = (Var s -> JsonVar s) -> Parser (Var s) -> Parser (JsonVar s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var s -> JsonVar s
forall (s :: Row *). Var s -> JsonVar s
JsonVar (Parser (Var s) -> Parser (JsonVar s))
-> Parser (Var s) -> Parser (JsonVar s)
forall a b. (a -> b) -> a -> b
$ do
      String -> (Object -> Parser (Var s)) -> Value -> Parser (Var s)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Var" (\Object
obj -> do
        String
theTag <- Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
        Value
theValue <- Object
obj Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
        String -> Value -> Parser (Var s)
forall (s :: Row *).
(AllUniqueLabels s, Forall s FromJSON) =>
String -> Value -> Parser (Var s)
namedBranchFromJSON String
theTag Value
theValue)
        Value
vl

instance Forall s ToJSON => ToJSON (JsonVar s) where
    toJSON :: JsonVar s -> Value
toJSON (JsonVar Var s
v) =
      let (Text
lbl, Value
vl) = (forall a. ToJSON a => a -> Value) -> Var s -> (Text, Value)
forall (c :: * -> Constraint) (ρ :: Row *) s b.
(Forall ρ c, IsString s) =>
(forall a. c a => a -> b) -> Var ρ -> (s, b)
Variants.eraseWithLabels @ToJSON @s  @Text @Aeson.Value forall a. ToJSON a => a -> Value
Aeson.toJSON Var s
v
      in [Pair] -> Value
Aeson.object [Key
"tag" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
lbl, Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
vl]

newtype JsonRec s = JsonRec { JsonRec s -> Rec s
unJsonRec :: Rec s }

-- | Parse a 'Var s' from JSON if the label of the branch is known.
namedBranchFromJSON :: forall s. (AllUniqueLabels s, Forall s FromJSON) => String -> Aeson.Value -> Aeson.Parser (Var s)
namedBranchFromJSON :: String -> Value -> Parser (Var s)
namedBranchFromJSON String
nm Value
vl =
  (forall (l :: Symbol) a.
 (KnownSymbol l, FromJSON a) =>
 Label l -> Parser a)
-> Parser (Var s)
forall (c :: * -> Constraint) (ρ :: Row *) (f :: * -> *).
(Alternative f, Forall ρ c, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a. (KnownSymbol l, c a) => Label l -> f a)
-> f (Var ρ)
Variants.fromLabels @FromJSON @s @Aeson.Parser (\case { Label l
n | Label l -> String
forall a. Show a => a -> String
show Label l
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nm -> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
vl; Label l
_ -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong label" })

instance Forall s ToJSON => ToJSON (JsonRec s) where
  toJSON :: JsonRec s -> Value
toJSON = [Pair] -> Value
Aeson.object ([Pair] -> Value) -> (JsonRec s -> [Pair]) -> JsonRec s -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToJSON a => a -> Value) -> Rec s -> [Pair]
forall (c :: * -> Constraint) (ρ :: Row *) s b.
(Forall ρ c, IsString s) =>
(forall a. c a => a -> b) -> Rec ρ -> [(s, b)]
Records.eraseWithLabels @ToJSON @s @Aeson.Key @Aeson.Value forall a. ToJSON a => a -> Value
Aeson.toJSON (Rec s -> [Pair]) -> (JsonRec s -> Rec s) -> JsonRec s -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRec s -> Rec s
forall (s :: Row *). JsonRec s -> Rec s
unJsonRec

instance (AllUniqueLabels s, Forall s FromJSON) => FromJSON (JsonRec s) where
  parseJSON :: Value -> Parser (JsonRec s)
parseJSON Value
vl = Rec s -> JsonRec s
forall (s :: Row *). Rec s -> JsonRec s
JsonRec (Rec s -> JsonRec s) -> Parser (Rec s) -> Parser (JsonRec s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (l :: Symbol) a.
 (KnownSymbol l, FromJSON a) =>
 Label l -> Parser a)
-> Parser (Rec s)
forall (c :: * -> Constraint) (f :: * -> *) (ρ :: Row *).
(Applicative f, Forall ρ c, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a. (KnownSymbol l, c a) => Label l -> f a)
-> f (Rec ρ)
Records.fromLabelsA @FromJSON @Aeson.Parser @s  (\Label l
lbl -> String -> (Object -> Parser a) -> Value -> Parser a
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Rec" (\Object
obj -> Object
obj Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: (String -> Key
Aeson.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Label l -> String
forall a. Show a => a -> String
show Label l
lbl) Parser Value -> (Value -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser a
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON) Value
vl)

-- | Fast diff. The implementation in row-types is exponential in time and memory in the number of
--   overlapping rows, due to limitations in ghc's handling of type families. This version is much
--   faster.
infixl 6 .\\ {- This comment needed to appease CPP -}
-- | Type level Row difference.  That is, @l '.\\' r@ is the row remaining after
-- removing any matching elements of @r@ from @l@.
type family (l :: Row k) .\\ (r :: Row k) :: Row k where
  'R l .\\ 'R r = 'R (Diff l r)

type family Diff (l :: [LT k]) (r :: [LT k]) where
  Diff '[] r = '[]
  Diff l '[] = l
  Diff (l ':-> al ': tl) (l ':-> al ': tr) = Diff tl tr
  Diff (hl ':-> al ': tl) (hr ':-> ar ': tr) =
    DiffCont (CmpSymbol hl hr) hl al tl hr ar tr

type family DiffCont (o :: Ordering)
                     (hl :: Symbol) (al :: k) (tl :: [LT k])
                     (hr :: Symbol) (ar :: k) (tr :: [LT k]) where
    DiffCont 'LT hl al tl hr ar tr =
      (hl ':-> al ': Diff tl (hr ':-> ar ': tr))
    DiffCont _ hl al tl hr ar tr =
      (Diff (hl ':-> al ': tl) tr)