-- |
-- 'Atom' and 'ToTransport' classes.

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
    FlexibleContexts #-}
{-# language DefaultSignatures, FlexibleInstances, TypeOperators, ScopedTypeVariables #-}

module Data.Autolib.Transport.Class (
    Transport(..),
    Trans(..),
    ToTransport(..)
) where

import Data.Autolib.Transport.Error
import Data.Autolib.Transport.Atom
import GHC.Generics
import Control.Applicative 

-- |
-- Intermediate data representation. It can contain atoms (Bool, Double,
-- Integer, String, ByteString), arrays (lists) and objects (maps with
-- string keys).
--
data Trans atom
    = TrAtom atom
    | TrArray [Trans atom]
    | TrObject [(String, Trans atom)]

-- |
-- Final conversion to transport layer.
--
class Atom atom => Transport base atom | base -> atom where
    encode :: Trans atom -> base
    decode :: base -> Error (Trans atom)

-- |
-- Conversion between data and intermediate representation.
--
class ToTransport a where
    -- | Convert data to intermediate representation.
    toTransport :: Atom atom => a -> Trans atom
    default toTransport :: (Generic a, GToTransport (Rep a), Atom atom) => a -> Trans atom
    toTransport = Type -> Rep a (ZonkAny 0) -> Trans atom
forall atom p. Atom atom => Type -> Rep a p -> Trans atom
forall (f :: * -> *) atom p.
(GToTransport f, Atom atom) =>
Type -> f p -> Trans atom
gToTransport Type
Pref (Rep a (ZonkAny 0) -> Trans atom)
-> (a -> Rep a (ZonkAny 0)) -> a -> Trans atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from
    
    -- | Convert intermediate representation to data.
    fromTransport :: Atom atom => Trans atom -> Error a
    default fromTransport :: (Generic a, GFromTransport (Rep a), Atom atom) => Trans atom -> Error a
    fromTransport Trans atom
t = Rep a (ZonkAny 1) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 1) -> a) -> Error (Rep a (ZonkAny 1)) -> Error a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Trans atom -> Error (Rep a (ZonkAny 1))
forall atom p. Atom atom => Type -> Trans atom -> Error (Rep a p)
forall (f :: * -> *) atom p.
(GFromTransport f, Atom atom) =>
Type -> Trans atom -> Error (f p)
gFromTransport Type
Pref Trans atom
t

    -- | This is analoguous to 'showList', used for the 'String' instance.
    toTransportList :: Atom atom => [a] -> Trans atom
    -- | This is analoguous to 'readList', used for the 'String' instance.
    fromTransportList :: Atom atom => Trans atom -> Error [a]

    toTransportList = [a] -> Trans atom
forall a atom. (ToTransport a, Atom atom) => [a] -> Trans atom
toTransportList0
    fromTransportList = Trans atom -> Error [a]
forall a atom.
(ToTransport a, Atom atom) =>
Trans atom -> Error [a]
fromTransportList0

toTransportList0 :: (ToTransport a, Atom atom) => [a] -> Trans atom
toTransportList0 :: forall a atom. (ToTransport a, Atom atom) => [a] -> Trans atom
toTransportList0 = [Trans atom] -> Trans atom
forall atom. [Trans atom] -> Trans atom
TrArray ([Trans atom] -> Trans atom)
-> ([a] -> [Trans atom]) -> [a] -> Trans atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Trans atom) -> [a] -> [Trans atom]
forall a b. (a -> b) -> [a] -> [b]
map a -> Trans atom
forall atom. Atom atom => a -> Trans atom
forall a atom. (ToTransport a, Atom atom) => a -> Trans atom
toTransport

fromTransportList0 :: (ToTransport a, Atom atom) => Trans atom -> Error [a]
fromTransportList0 :: forall a atom.
(ToTransport a, Atom atom) =>
Trans atom -> Error [a]
fromTransportList0 (TrArray [Trans atom]
xs) = (Trans atom -> Error a) -> [Trans atom] -> Error [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Trans atom -> Error a
forall atom. Atom atom => Trans atom -> Error a
forall a atom. (ToTransport a, Atom atom) => Trans atom -> Error a
fromTransport [Trans atom]
xs
fromTransportList0 Trans atom
_ = String -> Error [a]
forall a. String -> Error a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected TrArray"

-- | this is modelled after
-- https://github.com/dreixel/generic-deriving/blob/master/src/Generics/Deriving/Show.hs

data Type = Rec | Tup | Pref

class GToTransport f where
  gToTransport :: Atom atom => Type -> f p -> Trans atom
class GToTransportList f where
  gToTransportList :: Atom atom => Type -> f p -> [(String,Trans atom)]

instance GToTransport f => GToTransport (M1 D c f) where
  gToTransport :: forall atom p. Atom atom => Type -> M1 D c f p -> Trans atom
gToTransport Type
_ (M1 f p
x) = Type -> f p -> Trans atom
forall atom p. Atom atom => Type -> f p -> Trans atom
forall (f :: * -> *) atom p.
(GToTransport f, Atom atom) =>
Type -> f p -> Trans atom
gToTransport Type
Pref f p
x
instance (Constructor c, GToTransportList f) => GToTransport (C1 c f) where
  gToTransport :: forall atom p. Atom atom => Type -> C1 c f p -> Trans atom
gToTransport Type
_ c :: C1 c f p
c@(M1 f p
x) |  C1 c f p -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> Bool
conIsRecord C1 c f p
c =
    [(String, Trans atom)] -> Trans atom
forall atom. [(String, Trans atom)] -> Trans atom
TrObject [(C1 c f p -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName C1 c f p
c, [(String, Trans atom)] -> Trans atom
forall atom. [(String, Trans atom)] -> Trans atom
TrObject ([(String, Trans atom)] -> Trans atom)
-> [(String, Trans atom)] -> Trans atom
forall a b. (a -> b) -> a -> b
$ Type -> f p -> [(String, Trans atom)]
forall atom p. Atom atom => Type -> f p -> [(String, Trans atom)]
forall (f :: * -> *) atom p.
(GToTransportList f, Atom atom) =>
Type -> f p -> [(String, Trans atom)]
gToTransportList Type
Rec f p
x)]
  gToTransport Type
_ c :: C1 c f p
c@(M1 f p
x) | Bool -> Bool
not (C1 c f p -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> Bool
conIsRecord C1 c f p
c) =
    -- FIXME: check statically that we really have zero arguments
    [(String, Trans atom)] -> Trans atom
forall atom. [(String, Trans atom)] -> Trans atom
TrObject [(C1 c f p -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName C1 c f p
c, [Trans atom] -> Trans atom
forall atom. [Trans atom] -> Trans atom
TrArray [])] 
instance (Selector s, GToTransport f) => GToTransportList (S1 s f) where
  gToTransportList :: forall atom p.
Atom atom =>
Type -> S1 s f p -> [(String, Trans atom)]
gToTransportList Type
Rec s :: S1 s f p
s@(M1 f p
x) = [(S1 s f p -> 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 s f a -> String
selName S1 s f p
s, Type -> f p -> Trans atom
forall atom p. Atom atom => Type -> f p -> Trans atom
forall (f :: * -> *) atom p.
(GToTransport f, Atom atom) =>
Type -> f p -> Trans atom
gToTransport Type
Pref f p
x)]
instance (GToTransportList f, GToTransportList g) => GToTransportList (f :*: g) where
  gToTransportList :: forall atom p.
Atom atom =>
Type -> (:*:) f g p -> [(String, Trans atom)]
gToTransportList Type
t (f p
x :*: g p
y) = Type -> f p -> [(String, Trans atom)]
forall atom p. Atom atom => Type -> f p -> [(String, Trans atom)]
forall (f :: * -> *) atom p.
(GToTransportList f, Atom atom) =>
Type -> f p -> [(String, Trans atom)]
gToTransportList Type
t f p
x [(String, Trans atom)]
-> [(String, Trans atom)] -> [(String, Trans atom)]
forall a. [a] -> [a] -> [a]
++ Type -> g p -> [(String, Trans atom)]
forall atom p. Atom atom => Type -> g p -> [(String, Trans atom)]
forall (f :: * -> *) atom p.
(GToTransportList f, Atom atom) =>
Type -> f p -> [(String, Trans atom)]
gToTransportList Type
t g p
y
instance GToTransportList U1 where
  gToTransportList :: forall atom p. Atom atom => Type -> U1 p -> [(String, Trans atom)]
gToTransportList Type
_ U1 p
_ = []
instance (GToTransport f, GToTransport g) => GToTransport (f :+: g) where
  gToTransport :: forall atom p. Atom atom => Type -> (:+:) f g p -> Trans atom
gToTransport Type
_ (L1 f p
x) = Type -> f p -> Trans atom
forall atom p. Atom atom => Type -> f p -> Trans atom
forall (f :: * -> *) atom p.
(GToTransport f, Atom atom) =>
Type -> f p -> Trans atom
gToTransport Type
Pref f p
x
  gToTransport Type
_ (R1 g p
x) = Type -> g p -> Trans atom
forall atom p. Atom atom => Type -> g p -> Trans atom
forall (f :: * -> *) atom p.
(GToTransport f, Atom atom) =>
Type -> f p -> Trans atom
gToTransport Type
Pref g p
x
instance ToTransport c => GToTransport (K1 i c) where
  gToTransport :: forall atom p. Atom atom => Type -> K1 i c p -> Trans atom
gToTransport Type
_ K1 i c p
x = c -> Trans atom
forall atom. Atom atom => c -> Trans atom
forall a atom. (ToTransport a, Atom atom) => a -> Trans atom
toTransport (K1 i c p -> c
forall k i c (p :: k). K1 i c p -> c
unK1 K1 i c p
x)

class GFromTransport f where
  gFromTransport :: Atom atom => Type -> Trans atom -> Error (f p)
class GFromTransportList f where
  gFromTransportList :: Atom atom => Type -> [(String,Trans atom)] 
     -> Error (f p, [(String,Trans atom)])

instance GFromTransport f => GFromTransport (M1 D c f) where
  gFromTransport :: forall atom p.
Atom atom =>
Type -> Trans atom -> Error (M1 D c f p)
gFromTransport Type
_ Trans atom
tr = f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D c f p) -> Error (f p) -> Error (M1 D c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Trans atom -> Error (f p)
forall atom p. Atom atom => Type -> Trans atom -> Error (f p)
forall (f :: * -> *) atom p.
(GFromTransport f, Atom atom) =>
Type -> Trans atom -> Error (f p)
gFromTransport Type
Pref Trans atom
tr
instance (Constructor c, GFromTransportList f) => GFromTransport (C1 c f) where
  gFromTransport :: forall atom p. Atom atom => Type -> Trans atom -> Error (C1 c f p)
gFromTransport Type
_ Trans atom
tr =
    let c :: C1 c f p
c = C1 c f p
forall {p}. C1 c f p
forall a. HasCallStack => a
undefined :: C1 c f p
    in  case ( M1 C c f (ZonkAny 5) -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> Bool
conIsRecord M1 C c f (ZonkAny 5)
forall {p}. C1 c f p
c, Trans atom
tr ) of 
       ( Bool
True, TrObject [(String
name,TrObject [(String, Trans atom)]
args)] ) | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== M1 C c f (ZonkAny 6) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName M1 C c f (ZonkAny 6)
forall {p}. C1 c f p
c -> 
         do ( x, []) <- Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall (f :: * -> *) atom p.
(GFromTransportList f, Atom atom) =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
gFromTransportList Type
Rec [(String, Trans atom)]
args ; return $ M1 x
       ( Bool
False, TrObject [(String
name,TrArray (args :: [Trans atom]
args@[]))] ) | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== M1 C c f (ZonkAny 7) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName M1 C c f (ZonkAny 7)
forall {p}. C1 c f p
c -> do
         (x, []) <- Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall (f :: * -> *) atom p.
(GFromTransportList f, Atom atom) =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
gFromTransportList Type
Pref ([(String, Trans atom)] -> Error (f p, [(String, Trans atom)]))
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall a b. (a -> b) -> a -> b
$ [String] -> [Trans atom] -> [(String, Trans atom)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
forall a. a -> [a]
repeat String
"missing") [Trans atom]
args
         return $ M1 x
       (Bool, Trans atom)
_ -> String -> Error (C1 c f p)
forall a. String -> Error a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Error (C1 c f p)) -> String -> Error (C1 c f p)
forall a b. (a -> b) -> a -> b
$ String
"missing object with constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ M1 C c f (ZonkAny 8) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName M1 C c f (ZonkAny 8)
forall {p}. C1 c f p
c
instance (Selector s, GFromTransport f) => GFromTransportList (S1 s f) where
  gFromTransportList :: forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)]
-> Error (S1 s f p, [(String, Trans atom)])
gFromTransportList Type
Pref [(String, Trans atom)]
trs = do
    let s :: S1 s f p
s = S1 s f p
forall {p}. S1 s f p
forall a. HasCallStack => a
undefined :: S1 s f p
    String -> Error (S1 s f p, [(String, Trans atom)])
forall a. HasCallStack => String -> a
error (String -> Error (S1 s f p, [(String, Trans atom)]))
-> String -> Error (S1 s f p, [(String, Trans atom)])
forall a b. (a -> b) -> a -> b
$ String
"gFromTransportList " String -> String -> String
forall a. [a] -> [a] -> [a]
++ M1 S s f (ZonkAny 2) -> 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 s f a -> String
selName M1 S s f (ZonkAny 2)
forall {p}. S1 s f p
s
  gFromTransportList Type
Rec [(String, Trans atom)]
trs = do
    let s :: S1 s f p
s = S1 s f p
forall {p}. S1 s f p
forall a. HasCallStack => a
undefined :: S1 s f p
    case [(String, Trans atom)]
trs of 
      (String
name,Trans atom
arg) : [(String, Trans atom)]
later | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== M1 S s f (ZonkAny 3) -> 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 s f a -> String
selName M1 S s f (ZonkAny 3)
forall {p}. S1 s f p
s -> do
        x <- Type -> Trans atom -> Error (f p)
forall atom p. Atom atom => Type -> Trans atom -> Error (f p)
forall (f :: * -> *) atom p.
(GFromTransport f, Atom atom) =>
Type -> Trans atom -> Error (f p)
gFromTransport Type
Pref Trans atom
arg
        return ( M1 x , later )
      [(String, Trans atom)]
_ -> String -> Error (S1 s f p, [(String, Trans atom)])
forall a. String -> Error a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Error (S1 s f p, [(String, Trans atom)]))
-> String -> Error (S1 s f p, [(String, Trans atom)])
forall a b. (a -> b) -> a -> b
$ String
"missing record component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ M1 S s f (ZonkAny 4) -> 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 s f a -> String
selName M1 S s f (ZonkAny 4)
forall {p}. S1 s f p
s
instance (GFromTransportList f, GFromTransportList g) => GFromTransportList (f :*: g) where
  gFromTransportList :: forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)]
-> Error ((:*:) f g p, [(String, Trans atom)])
gFromTransportList Type
t [(String, Trans atom)]
trs = do
    (x, trs) <- Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
forall (f :: * -> *) atom p.
(GFromTransportList f, Atom atom) =>
Type
-> [(String, Trans atom)] -> Error (f p, [(String, Trans atom)])
gFromTransportList Type
t [(String, Trans atom)]
trs
    (y, trs) <- gFromTransportList t trs
    return (x :*: y, trs)
instance ToTransport c => GFromTransport (K1 i c) where
  gFromTransport :: forall atom p. Atom atom => Type -> Trans atom -> Error (K1 i c p)
gFromTransport Type
_ Trans atom
x = c -> K1 i c p
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 i c p) -> Error c -> Error (K1 i c p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trans atom -> Error c
forall atom. Atom atom => Trans atom -> Error c
forall a atom. (ToTransport a, Atom atom) => Trans atom -> Error a
fromTransport Trans atom
x
instance (GFromTransport f, GFromTransport g) => GFromTransport (f :+: g) where
  gFromTransport :: forall atom p.
Atom atom =>
Type -> Trans atom -> Error ((:+:) f g p)
gFromTransport Type
t Trans atom
tr = ( f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> Error (f p) -> Error ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Trans atom -> Error (f p)
forall atom p. Atom atom => Type -> Trans atom -> Error (f p)
forall (f :: * -> *) atom p.
(GFromTransport f, Atom atom) =>
Type -> Trans atom -> Error (f p)
gFromTransport Type
t Trans atom
tr ) Error ((:+:) f g p) -> Error ((:+:) f g p) -> Error ((:+:) f g p)
forall a. Error a -> Error a -> Error a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> Error (g p) -> Error ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Trans atom -> Error (g p)
forall atom p. Atom atom => Type -> Trans atom -> Error (g p)
forall (f :: * -> *) atom p.
(GFromTransport f, Atom atom) =>
Type -> Trans atom -> Error (f p)
gFromTransport Type
t Trans atom
tr )
instance GFromTransportList U1 where
  gFromTransportList :: forall atom p.
Atom atom =>
Type
-> [(String, Trans atom)] -> Error (U1 p, [(String, Trans atom)])
gFromTransportList Type
_ [(String, Trans atom)]
trs = (U1 p, [(String, Trans atom)])
-> Error (U1 p, [(String, Trans atom)])
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return (U1 p
forall k (p :: k). U1 p
U1, [(String, Trans atom)]
trs)