{-
	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 FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE QuasiQuotes            #-}

module Data.Types.Reorder.Sum (
		addSumType,
		setSumType,
		getSumType,
		emptySum,
		SumType(..),
		AddSumType,
		(:+:),
		OutSumType,
		(:>:),
		InSumType,
		(:<:)
	) where

import Data.Types.Reorder.Base
import Data.Types.Reorder.Quoter
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (nameBase)

data SumType       a b = SumTypeLeft a | SumTypeRight b
type SumTypeOrder  a t = GetTypeOrder SumType a t

emptySum = reorderableEnd

type instance TypeOrder x (SumType l r) = TypeOrder_Composition

makeSumOrderingFlag :: without -> t -> SumTypeOrder without t
makeSumOrderingFlag _ _ = undefined

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

class
		AddSumTypeClass flag without t with | flag without t -> with
	where
		type AddSumType' flag without t
		
		addSumType' :: flag -> without -> t -> with

-- | If we end up with two `ReorderableEnd's being added together just return
-- one.  This is generally only encountered when combining two Sum types.
instance
		AddSumTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd
	where
		type AddSumType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd
		
		addSumType' _ _ _ = reorderableEnd

-- | Compose two Sum types in to one large one recursively.
instance
		(AddSumTypeClass (SumTypeOrder without r) without r with',
		 AddSumTypeClass (SumTypeOrder with'   l) with'   l with) =>
		AddSumTypeClass TypeOrder_Composition without (SumType l r) with
	where
		type AddSumType' TypeOrder_Composition without (SumType l r) =
			AddSumType'
				(SumTypeOrder (AddSumType' (SumTypeOrder without r) without r) l)
				(AddSumType' (SumTypeOrder without r) without r) l
		
		addSumType' _ w _ = undefined

-- | Add a type to the end of the current Sum.
instance
		AddSumTypeClass TypeOrder_Lower without t (SumType without t)
	where
		type AddSumType' TypeOrder_Lower without t = SumType without t
		
		addSumType' _ x _ = SumTypeLeft x

-- | Add a type deeper in to the current Sum.
instance
		(AddSumTypeClass (SumTypeOrder l t) l t with) =>
		AddSumTypeClass TypeOrder_Higher (SumType l r) t (SumType with r)
	where
		type AddSumType' TypeOrder_Higher (SumType l r) t = SumType (AddSumType' (SumTypeOrder l t) l t) r
		
		addSumType' _ (SumTypeLeft  l) t = SumTypeLeft (addSumType l t)
		addSumType' _ (SumTypeRight r) _ = SumTypeRight r
		-- -- The unwrap/wrap is required to change the constructor's type.

addSumType w t = addSumType' (makeSumOrderingFlag w t) w t

-- | Add type.
type AddSumType without t = AddSumType' (SumTypeOrder without t) without t
type (:+:) without t = AddSumType without t -- Can't curry types :(.

-- | Doesn't have type.
type OutSumType without t = AddSumTypeClass (SumTypeOrder without t) without t (AddSumType without t)
type (:>:) t without = OutSumType without t

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

class
		HasSumTypeClass flag with t
	where
		setSumType' :: flag -> with -> t -> with
		getSumType' :: flag -> with -> t -> Maybe t

-- | If we end up with two `ReorderableEnd's being added together just return
-- one.  This is generally only encountered when combining two Sum types.
instance
		HasSumTypeClass TypeOrder_End ReorderableEnd ReorderableEnd
	where
		setSumType' _ _ _ = reorderableEnd
		getSumType' _ _ _ = Nothing

instance
		HasSumTypeClass TypeOrder_Same (SumType without t) t
	where
		setSumType' _  _               x = SumTypeRight x
		getSumType' _ (SumTypeLeft  _) _ = Nothing
		getSumType' _ (SumTypeRight r) _ = Just r

instance
		(HasSumTypeClass (SumTypeOrder l t) l t) =>
		HasSumTypeClass TypeOrder_Higher (SumType l r) t
	where
		setSumType' _  _               x = SumTypeLeft (setSumType (undefined :: l) x)
		getSumType' _ (SumTypeLeft  l) x = getSumType l x
		getSumType' _ (SumTypeRight _) _ = Nothing

setSumType w t = setSumType' (makeSumOrderingFlag w t) w t
getSumType w t = getSumType' (makeSumOrderingFlag w t) w t

-- | Has type.
type InSumType with t = HasSumTypeClass (SumTypeOrder with t) with t

type (:<:) t with = InSumType with t

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

-- This code is the generator for "SumType" instance generation.
class ReorderableSum a

[reorderer|ReorderableSum
	addSum??? :: (OutSumType without ???) => without -> AddSumType without ???
	addSum??? without = addSumType without (undefined :: ???)
	
	-- createSum??? :: (InSumType with ???) => ??? -> with
	-- createSum??? = setSumType (undefined :: with)
	
	setSum??? :: (InSumType with ???) => ??? -> with -> with
	setSum??? a b = setSumType b a
	
	getSum??? :: (InSumType with ???) => with -> Maybe ???
	getSum??? with = getSumType with (undefined :: ???)
|]