Serialize.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Iota.Serialize where
import GHC.Generics
import Text.Read (readMaybe)
import GHC.Base ((<|>))
import Data.Data (Proxy)
import Agda.Utils.Either (mapRight)
import Control.Arrow (second)

data Foo = YesFoo Bar | NoFoo deriving (Generic, Show)
data Bar = Bar { barFoo :: Foo, value :: Int } deriving (Generic, Show)
data SExpr = SApp SExpr SExpr | SName String deriving (Eq)

instance Show SExpr where
    show (SApp a b@(SApp _ _)) = (show a) ++ " (" ++ show b ++ ")"
    show (SApp a (SName b)) = (show a) ++ " " ++ show b
    show (SName s) = show s

class Converter a where
    toSExpr :: a -> SExpr
    default toSExpr :: (Generic a, GConverter (Rep a)) => a -> SExpr
    toSExpr = gToSExpr . from

    fromSExpr :: SExpr -> Maybe a
    default fromSExpr :: (Generic a, GConverter (Rep a)) => SExpr -> Maybe a
    fromSExpr x = to <$> gFromSExpr x

class GConverter f where
    gToSExpr :: f p -> SExpr
    gFromSExpr :: SExpr -> Maybe (f p)

class GConverterList f where
    gToSExprList :: f p -> [SExpr]
    gFromSExprList :: [SExpr] -> Maybe ([SExpr], f p)

instance (GConverterList a, GConverterList b) => GConverterList (a :*: b) where
    gToSExprList (a :*: b) = gToSExprList a ++ gToSExprList b
    gFromSExprList l = do
        (l', a) <- gFromSExprList l
        (l'', b) <- gFromSExprList l'
        return (l'', a :*: b)

instance GConverter a => GConverterList (S1 c a) where
    gToSExprList (M1 a) = [gToSExpr a]
    gFromSExprList (a : l) = do
        a' <- gFromSExpr a
        return (l, M1 a')
    gFromSExprList [] = Nothing

instance (GConverter a, GConverter b) => GConverter (a :+: b) where
    gToSExpr (L1 x) = gToSExpr x
    gToSExpr (R1 x) = gToSExpr x
    gFromSExpr s = (L1 <$> gFromSExpr s) <|> (R1 <$> gFromSExpr s)

instance (GConverter a, Datatype d) => GConverter (M1 D d a) where
    gToSExpr (M1 x) = gToSExpr x
    gFromSExpr e = fmap M1 $ gFromSExpr e

instance (GConverterList a, Constructor c) => GConverter (C1 c a) where
    gToSExpr m@(M1 x) = foldl SApp (SName $ conName m) (gToSExprList x)
    gFromSExpr e =
        let
            split :: SExpr -> (String, [SExpr])
            split (SName s) = (s, [])
            split (SApp a b) = second ((:) b) $ split a
            (n , a) = split e
            cn = conName (undefined :: C1 c a p)
        in
        if n == cn then
            case gFromSExprList (reverse a) of
                (Just ([], a)) -> Just $ M1 a
                _ -> Nothing
        else Nothing

instance {-# OVERLAPPING #-} (Constructor c) => GConverter (C1 c U1) where
    gToSExpr m = SName $ conName m
    gFromSExpr e@(SApp _ _) = Nothing
    gFromSExpr (SName name)
        | name == conName (undefined :: C1 c a p) = Just $ M1 U1
    gFromSExpr e = Nothing

instance (GConverter a, Selector s) => GConverter (S1 s a) where
    gToSExpr (M1 x) = gToSExpr x
    gFromSExpr = fmap M1 . gFromSExpr

instance (Converter c) => GConverter (K1 i c) where
    gToSExpr (K1 x) = toSExpr x
    gFromSExpr e = fmap K1 $ fromSExpr e

instance Converter Int where
  toSExpr n = SName (show n)
  fromSExpr (SName s) = readMaybe s
  fromSExpr _ = Nothing

instance Converter Foo where
instance Converter Bar where

x = toSExpr (Bar (YesFoo (Bar NoFoo 123)) 456)
x2 = SApp (SApp (SName "Bar") (SApp (SName "YesFoo") (SApp (SApp (SName "Bar") (SName "NoFoo")) (SName "123")))) (SName "456")
x3 = fromSExpr x :: Maybe Bar