toysolver-0.9.0: src/ToySolver/Converter/Base.hs

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Converter.Base
-- Copyright   :  (c) Masahiro Sakai 2018
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module ToySolver.Converter.Base
  ( Transformer (..)
  , ForwardTransformer (..)
  , BackwardTransformer (..)
  , ObjValueTransformer (..)
  , ObjValueForwardTransformer (..)
  , ObjValueBackwardTransformer (..)
  , ComposedTransformer (..)
  , IdentityTransformer (..)
  , ReversedTransformer (..)
  ) where

import qualified Data.Aeson as J
import Data.Aeson ((.=), (.:))
import ToySolver.Internal.JSON (withTypedObject)

class (Eq a, Show a) => Transformer a where
  type Source a
  type Target a

class Transformer a => ForwardTransformer a where
  transformForward :: a -> Source a -> Target a

class Transformer a => BackwardTransformer a where
  transformBackward :: a -> Target a -> Source a


class ObjValueTransformer a where
  type SourceObjValue a
  type TargetObjValue a

class ObjValueTransformer a => ObjValueForwardTransformer a where
  transformObjValueForward :: a -> SourceObjValue a -> TargetObjValue a

class ObjValueTransformer a => ObjValueBackwardTransformer a where
  transformObjValueBackward :: a -> TargetObjValue a -> SourceObjValue a


data ComposedTransformer a b = ComposedTransformer a b
  deriving (Eq, Show, Read)

instance (Transformer a, Transformer b, Target a ~ Source b) => Transformer (ComposedTransformer a b) where
  type Source (ComposedTransformer a b) = Source a
  type Target (ComposedTransformer a b) = Target b

instance (ForwardTransformer a, ForwardTransformer b, Target a ~ Source b)
  => ForwardTransformer (ComposedTransformer a b) where
  transformForward (ComposedTransformer a b) = transformForward b . transformForward a

instance (BackwardTransformer a, BackwardTransformer b, Target a ~ Source b)
  => BackwardTransformer (ComposedTransformer a b) where
  transformBackward (ComposedTransformer a b) = transformBackward a . transformBackward b


instance (ObjValueTransformer a, ObjValueTransformer b, TargetObjValue a ~ SourceObjValue b)
  => ObjValueTransformer (ComposedTransformer a b) where
  type SourceObjValue (ComposedTransformer a b) = SourceObjValue a
  type TargetObjValue (ComposedTransformer a b) = TargetObjValue b

instance (ObjValueForwardTransformer a, ObjValueForwardTransformer b, TargetObjValue a ~ SourceObjValue b)
  => ObjValueForwardTransformer (ComposedTransformer a b) where
  transformObjValueForward (ComposedTransformer a b) = transformObjValueForward b . transformObjValueForward a

instance (ObjValueBackwardTransformer a, ObjValueBackwardTransformer b, TargetObjValue a ~ SourceObjValue b)
  => ObjValueBackwardTransformer (ComposedTransformer a b) where
  transformObjValueBackward (ComposedTransformer a b) = transformObjValueBackward a . transformObjValueBackward b

instance (J.ToJSON a, J.ToJSON b) => J.ToJSON (ComposedTransformer a b) where
  toJSON (ComposedTransformer a b) =
    J.object
    [ "type" .= J.String "ComposedTransformer"
    , "first" .= a
    , "second" .= b
    ]

instance (J.FromJSON a, J.FromJSON b) => J.FromJSON (ComposedTransformer a b) where
  parseJSON = withTypedObject "ComposedTransformer" $ \obj -> do
    ComposedTransformer
      <$> obj .: "first"
      <*> obj .: "second"


data IdentityTransformer a = IdentityTransformer
  deriving (Eq, Show, Read)

instance Transformer (IdentityTransformer a) where
  type Source (IdentityTransformer a) = a
  type Target (IdentityTransformer a) = a

instance ForwardTransformer (IdentityTransformer a) where
  transformForward IdentityTransformer = id

instance BackwardTransformer (IdentityTransformer a) where
  transformBackward IdentityTransformer = id

instance J.ToJSON (IdentityTransformer a) where
  toJSON IdentityTransformer =
    J.object
    [ "type" .= J.String "IdentityTransformer"
    ]

instance J.FromJSON (IdentityTransformer a) where
  parseJSON = withTypedObject "IdentityTransformer" $ \_ -> pure IdentityTransformer


newtype ReversedTransformer t = ReversedTransformer t
  deriving (Eq, Show, Read)

instance Transformer t => Transformer (ReversedTransformer t) where
  type Source (ReversedTransformer t) = Target t
  type Target (ReversedTransformer t) = Source t

instance BackwardTransformer t => ForwardTransformer (ReversedTransformer t) where
  transformForward (ReversedTransformer t) = transformBackward t

instance ForwardTransformer t => BackwardTransformer (ReversedTransformer t) where
  transformBackward (ReversedTransformer t) = transformForward t

instance ObjValueTransformer t => ObjValueTransformer (ReversedTransformer t) where
  type SourceObjValue (ReversedTransformer t) = TargetObjValue t
  type TargetObjValue (ReversedTransformer t) = SourceObjValue t

instance ObjValueBackwardTransformer t => ObjValueForwardTransformer (ReversedTransformer t) where
  transformObjValueForward (ReversedTransformer t) = transformObjValueBackward t

instance ObjValueForwardTransformer t => ObjValueBackwardTransformer (ReversedTransformer t) where
  transformObjValueBackward (ReversedTransformer t) = transformObjValueForward t

instance J.ToJSON t => J.ToJSON (ReversedTransformer t) where
  toJSON (ReversedTransformer t) =
    J.object
    [ "type" .= ("ReversedTransformer" :: J.Value)
    , "base" .= t
    ]

instance J.FromJSON t => J.FromJSON (ReversedTransformer t) where
  parseJSON = withTypedObject "ReversedTransformer" $ \v ->
    ReversedTransformer <$> v .: "base"