{-
	Copyright (c) 2013, Alex Cole
	
	This Source Code Form is subject to the terms of the Mozilla Public License,
	v. 2.0. If a copy of the MPL was not distributed with this file, You can
	obtain one at http://mozilla.org/MPL/2.0/.
-}

{-# LANGUAGE MultiParamTypeClasses #-}
{- # LANGUAGE OverlappingInstances  #-}
{-# LANGUAGE FlexibleInstances     #-}

module Data.Types.Reorder.Instances (
		debugProductType
	) where

import Data.Types.Reorder.Base
import Data.Types.Reorder.Product
import Data.Types.Reorder.Sum

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

instance (Eq a, Eq b) => Eq (ProductType a b) where
	ProductType l0 l1 == ProductType r0 r1 = l0 == r0 && l1 == r1
	ProductType l0 l1 /= ProductType r0 r1 = l0 /= r0 || l1 /= r1

instance (Eq b) => Eq (ProductType ReorderableEnd b) where
	ProductType _ l1 == ProductType _ r1 = l1 == r1
	ProductType _ l1 /= ProductType _ r1 = l1 /= r1

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

sep c = (c :) . (' ' :)

class ShowProductType x y where
	showProductType  :: ProductType x y -> ShowS
	debugProductType :: ProductType x y -> String

-- For things that don't use "ReorderableEnd".
instance (Show x, Show y) => ShowProductType x y where
	showProductType  (ProductType l r) = shows l . sep ',' . shows r
	debugProductType (ProductType l r) = "<(END), " ++ show l ++ ", " ++ show r ++ ">"

instance (ShowProductType a b, Show y) => ShowProductType (ProductType a b) y where
	showProductType  (ProductType l r) = showProductType  l . sep ',' . shows r
	debugProductType (ProductType l r) = "<" ++ debugProductType l ++ ", " ++ show r ++ ">"

-- Don't show the type sentinel ever.
instance (Show y) => ShowProductType ReorderableEnd y where
	showProductType  (ProductType _ r) = shows r
	debugProductType (ProductType _ r) = "<(END), " ++ show r ++ ">"

instance (ShowProductType a b) => Show (ProductType a b) where
	-- Ignore precedence, we always use angle brackets here.
	showsPrec _ x = ('<' :) . showProductType x . ('>' :)
	show x = '<' : showProductType x ">"

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

instance (Eq a, Eq b) => Eq (SumType a b) where
	SumTypeLeft  l0 == SumTypeLeft  l1 = l0 == l1
	SumTypeRight r0 == SumTypeRight r1 = r0 == r1
	_ == _ = False
	SumTypeLeft  l0 /= SumTypeLeft  l1 = l0 /= l1
	SumTypeRight r0 /= SumTypeRight r1 = r0 /= r1
	_ /= _ = True

instance (Eq b) => Eq (SumType ReorderableEnd b) where
	SumTypeRight r0 == SumTypeRight r1 = r0 == r1
	_ == _ = False
	SumTypeRight r0 /= SumTypeRight r1 = r0 /= r1
	_ /= _ = True

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

-- I did write a VASTLY more generic version of this class that could handle any
-- arbitrary tree of sum types (growing left and right), rather than just the
-- nicely ordered types created by this code.
class ShowSumType x y where
	showSumType :: SumType x y -> ShowS

instance (ShowSumType a b, Show y) => ShowSumType (SumType a b) y where
	showSumType (SumTypeLeft  l) = ('<' :) . showSumType l
	showSumType (SumTypeRight r) = ('>' :) . showsPrec 0 r

-- Don't show the type sentinel ever.
instance (Show y) => ShowSumType ReorderableEnd y where
	showSumType (SumTypeLeft  _) = ('-' :)
	showSumType (SumTypeRight r) = ('>' :) . showsPrec 0 r

instance (ShowSumType l r) => Show (SumType l r) where
	showsPrec _ a = ('(' :) . showSumType a . (')' :)
	show a = '(' : showSumType a ")"

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

instance (Read a, Read b) => Read (SumType a b) where
	readsPrec prec str@(h : rest)
			|  h == '(' = readParen True (readsPrec prec) str
			|  h == '<' = [(SumTypeLeft  left, leftRem)]
			|  h == '>' = [(SumTypeRight rite, riteRem)]
			| otherwise = []
		where
			((left, leftRem) : _) = readsPrec prec rest
			((rite, riteRem) : _) = readsPrec prec rest