{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Interpreter to duplicate the representation of an expression
-- in order to evaluate it with different interpreters.
--
-- NOTE: this is a more verbose, less clear,
-- and maybe less efficient alternative
-- to maintaining the universal polymorphism of @repr@ at parsing time
-- as done with 'Forall_Repr_with_Context';
-- it is mainly here for the sake of curiosity.
module Language.Symantic.Repr.Dup where

import Data.Foldable (foldr)

import Language.Symantic.Expr

-- | Interpreter's data.
data Dup repr1 repr2 a
 =   Dup
 {   dup1 :: repr1 a
 ,   dup2 :: repr2 a
 }

instance -- Sym_Bool
 ( Sym_Bool r1
 , Sym_Bool r2
 ) => Sym_Bool (Dup r1 r2) where
	bool x = bool x `Dup` bool x
	not  (x1 `Dup` x2)               = not  x1    `Dup` not  x2
	(&&) (x1 `Dup` x2) (y1 `Dup` y2) = (&&) x1 y1 `Dup` (&&) x2 y2
	(||) (x1 `Dup` x2) (y1 `Dup` y2) = (||) x1 y1 `Dup` (||) x2 y2
	xor  (x1 `Dup` x2) (y1 `Dup` y2) = xor  x1 y1 `Dup` xor  x2 y2
instance -- Sym_Int
 ( Sym_Int r1
 , Sym_Int r2
 ) => Sym_Int (Dup r1 r2) where
	int     x                          = int x     `Dup` int x
	abs    (x1 `Dup` x2)               = abs x1    `Dup` abs x2
	negate (x1 `Dup` x2)               = negate x1 `Dup` negate x2
	(+)    (x1 `Dup` x2) (y1 `Dup` y2) = (+) x1 y1 `Dup` (+) x2 y2
	(-)    (x1 `Dup` x2) (y1 `Dup` y2) = (-) x1 y1 `Dup` (-) x2 y2
	(*)    (x1 `Dup` x2) (y1 `Dup` y2) = (*) x1 y1 `Dup` (*) x2 y2
	mod    (x1 `Dup` x2) (y1 `Dup` y2) = mod x1 y1 `Dup` mod x2 y2
instance -- Sym_Eq
 ( Sym_Eq r1
 , Sym_Eq r2
 ) => Sym_Eq (Dup r1 r2) where
	(==) (x1 `Dup` x2) (y1 `Dup` y2) = (==) x1 y1 `Dup` (==) x2 y2
instance -- Sym_Ord
 ( Sym_Ord r1
 , Sym_Ord r2
 ) => Sym_Ord (Dup r1 r2) where
	compare (x1 `Dup` x2) (y1 `Dup` y2) =
		compare x1 y1 `Dup` compare x2 y2
instance -- Sym_If
 ( Sym_If r1
 , Sym_If r2
 ) => Sym_If (Dup r1 r2) where
	if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
		if_ c1 ok1 ko1 `Dup` if_ c2 ok2 ko2
instance -- Sym_When
 ( Sym_When r1
 , Sym_When r2
 ) => Sym_When (Dup r1 r2) where
	when (c1 `Dup` c2) (ok1 `Dup` ok2) =
		when c1 ok1 `Dup` when c2 ok2
instance -- Sym_List
 ( Sym_List r1
 , Sym_List r2
 ) => Sym_List (Dup r1 r2) where
	list_empty = list_empty `Dup` list_empty
	list_cons (a1 `Dup` a2) (l1 `Dup` l2) = list_cons a1 l1 `Dup` list_cons a2 l2
	list l =
		let (l1, l2) =
			foldr (\(x1 `Dup` x2) (xs1, xs2) ->
				(x1:xs1, x2:xs2)) ([], []) l in
		list l1 `Dup` list l2
	list_filter (f1 `Dup` f2) (l1 `Dup` l2) =
		list_filter f1 l1 `Dup` list_filter f2 l2
instance -- Sym_Maybe
 ( Sym_Maybe r1
 , Sym_Maybe r2
 ) => Sym_Maybe (Dup r1 r2) where
	nothing = nothing `Dup` nothing
	just (a1 `Dup` a2) = just a1 `Dup` just a2
	maybe (m1 `Dup` m2) (n1 `Dup` n2) (j1 `Dup` j2) =
		maybe m1 n1 j1 `Dup`
		maybe m2 n2 j2
instance -- Sym_Lambda
 ( Sym_Lambda r1
 , Sym_Lambda r2
 ) => Sym_Lambda (Dup r1 r2) where
	($$) (f1 `Dup` f2) (x1 `Dup` x2) = ($$) f1 x1 `Dup` ($$) f2 x2
	lam f = dup1 (lam f) `Dup` dup2 (lam f)
instance -- Sym_Tuple2
 ( Sym_Tuple2 r1
 , Sym_Tuple2 r2
 ) => Sym_Tuple2 (Dup r1 r2) where
	tuple2 (a1 `Dup` a2) (b1 `Dup` b2) =
		tuple2 a1 b1 `Dup` tuple2 a2 b2
instance -- Sym_Map
 ( Sym_Map r1
 , Sym_Map r2
 ) => Sym_Map (Dup r1 r2) where
	map_from_list (l1 `Dup` l2) =
		map_from_list l1 `Dup` map_from_list l2
	mapWithKey (f1 `Dup` f2) (m1 `Dup` m2) =
		mapWithKey f1 m1 `Dup` mapWithKey f2 m2
instance -- Sym_Functor
 ( Sym_Functor r1
 , Sym_Functor r2
 ) => Sym_Functor (Dup r1 r2) where
	fmap (f1 `Dup` f2) (m1 `Dup` m2) =
		fmap f1 m1 `Dup` fmap f2 m2
instance -- Sym_Applicative
 ( Sym_Applicative r1
 , Sym_Applicative r2
 ) => Sym_Applicative (Dup r1 r2) where
	pure (a1 `Dup` a2) =
		pure a1 `Dup` pure a2
	(<*>) (f1 `Dup` f2) (m1 `Dup` m2) =
		(<*>) f1 m1 `Dup` (<*>) f2 m2
instance -- Sym_Traversable
 ( Sym_Traversable r1
 , Sym_Traversable r2
 ) => Sym_Traversable (Dup r1 r2) where
	traverse (f1 `Dup` f2) (m1 `Dup` m2) =
		traverse f1 m1 `Dup` traverse f2 m2
instance -- Sym_Monad
 ( Sym_Monad r1
 , Sym_Monad r2
 ) => Sym_Monad (Dup r1 r2) where
	return (a1 `Dup` a2) =
		return a1 `Dup` return a2
	(>>=) (m1 `Dup` m2) (f1 `Dup` f2) =
		(>>=) m1 f1 `Dup` (>>=) m2 f2