{-
	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.Product (
		removeProductType,
		addProductType,
		setProductType,
		getProductType,
		emptyProduct,
		ProductType(..),
		AddProductType,
		(:*:),
		RemoveProductType,
		(:-:),
		OutProductType,
		(:~:),
		InProductType,
		(:?:)
	) where

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

data ProductType       a b = ProductType a b
type ProductTypeOrder  a t = GetTypeOrder ProductType a t

emptyProduct = reorderableEnd

type instance TypeOrder x (ProductType l r) = TypeOrder_Composition

makeProductOrderingFlag :: without -> t -> ProductTypeOrder without t
makeProductOrderingFlag _ _ = undefined

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

class
		AddProductTypeClass flag without t with | flag without t -> with
	where
		type AddProductType' flag without t
		addProductType' :: 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 product types.
instance
		AddProductTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd
	where
		type AddProductType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd
		addProductType' _ _ _ = reorderableEnd

-- | Compose two product types in to one large one recursively.
instance
		(AddProductTypeClass (ProductTypeOrder without r) without r with',
		 AddProductTypeClass (ProductTypeOrder with'   l) with'   l with) =>
		AddProductTypeClass TypeOrder_Composition without (ProductType l r) with
	where
		type AddProductType' TypeOrder_Composition without (ProductType l r) =
			AddProductType'
				(ProductTypeOrder (AddProductType' (ProductTypeOrder without r) without r) l)
				(AddProductType' (ProductTypeOrder without r) without r) l
		addProductType' _ without (ProductType l r) = addProductType (addProductType without r) l

-- | Add a type to the end of the current product.
instance
		AddProductTypeClass TypeOrder_Lower without t (ProductType without t)
	where
		type AddProductType' TypeOrder_Lower without t = ProductType without t
		addProductType' _ = ProductType

-- | Add a type deeper in to the current product.
instance
		(AddProductTypeClass (ProductTypeOrder l t) l t with) =>
		AddProductTypeClass TypeOrder_Higher (ProductType l r) t (ProductType with r)
	where
		type AddProductType' TypeOrder_Higher (ProductType l r) t = ProductType (AddProductType' (ProductTypeOrder l t) l t) r
		addProductType' _ (ProductType l r) t = ProductType (addProductType l t) r

addProductType w t = addProductType' (makeProductOrderingFlag w t) w t

-- | Add type.
type AddProductType without t = AddProductType' (ProductTypeOrder without t) without t
type (:*:) without t = AddProductType without t -- Can't curry types :(.

-- | Doesn't have type.
type OutProductType without t = AddProductTypeClass (ProductTypeOrder without t) without t (AddProductType without t)
type (:~:) t without = OutProductType without t

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

class
		HasProductTypeClass flag with t without | flag with t -> without
	where
		type RemoveProductType' flag with t
		removeProductType' :: flag -> with -> t -> without
		
		setProductType' :: flag -> with -> t -> with
		getProductType' :: flag -> with -> t -> t

-- | If we end up with two `ReorderableEnd's being added together just return
-- one.  This is generally only encountered when combining two product types.
instance
		HasProductTypeClass TypeOrder_End ReorderableEnd ReorderableEnd ReorderableEnd
	where
		type RemoveProductType' TypeOrder_End ReorderableEnd ReorderableEnd = ReorderableEnd
		removeProductType' _ _ _ = reorderableEnd
		
		setProductType' _ _ _ = reorderableEnd
		getProductType' _ _ _ = reorderableEnd

-- | Compose two product types in to one large one recursively.
instance
		-- This would not be required if the definition of `getProductType'
		-- could use @getProductType with' l@ where @with'@ is the remaining
		-- types from @getProductType with r@ after getting @r@, in which case
		-- the other two constraints would suffice.  Unfortunately we can't, but
		-- this constraint encompasses the other two, so its all good.
		(HasProductTypeClass (ProductTypeOrder with     l) with     l without_,
		-- These are required recursive constraints.
		 HasProductTypeClass (ProductTypeOrder with     r) with     r without',
		 HasProductTypeClass (ProductTypeOrder without' l) without' l without) =>
		HasProductTypeClass TypeOrder_Composition with (ProductType l r) without
	where
		type RemoveProductType' TypeOrder_Composition with (ProductType l r) =
			RemoveProductType'
				(ProductTypeOrder (RemoveProductType' (ProductTypeOrder with r) with r) l)
				(RemoveProductType' (ProductTypeOrder with r) with r) l
		removeProductType' _ with (ProductType l r) = removeProductType (removeProductType with r) l
		
		setProductType' _ with (ProductType l r) = setProductType (setProductType with r) l
		getProductType' _ with (ProductType l r) = ProductType (getProductType with l) (getProductType with r)

instance
		HasProductTypeClass TypeOrder_Same (ProductType without t) t without
	where
		type RemoveProductType' TypeOrder_Same (ProductType without t) t = without
		removeProductType' _ (ProductType l _) _ = l
		
		setProductType' _ (ProductType l _) x = ProductType l x
		getProductType' _ (ProductType _ r) _ = r

instance
		(HasProductTypeClass (ProductTypeOrder l t) l t without) =>
		HasProductTypeClass TypeOrder_Higher (ProductType l r) t (ProductType without r)
	where
		type RemoveProductType' TypeOrder_Higher (ProductType l r) t = ProductType (RemoveProductType' (ProductTypeOrder l t) l t) r
		removeProductType' _ (ProductType l r) t = ProductType (removeProductType l t) r
		
		setProductType' _ (ProductType l r) t = ProductType (setProductType l t) r
		getProductType' _ (ProductType l _) t = getProductType l t

removeProductType w t = removeProductType' (makeProductOrderingFlag w t) w t
setProductType w t = setProductType' (makeProductOrderingFlag w t) w t
getProductType w t = getProductType' (makeProductOrderingFlag w t) w t

-- | Remove type.
type RemoveProductType with t = RemoveProductType' (ProductTypeOrder with t) with t
type (:-:) with t = RemoveProductType with t

-- | Has type.
type InProductType with t = HasProductTypeClass (ProductTypeOrder with t) with t (RemoveProductType with t)
type (:?:) t with = InProductType with t

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

-- This code is the generator for "ProductType" instance generation.

-- productInstanceGenerator :: Name -> [Dec]
-- productInstanceGenerator new = buildProductInstances
	-- where
		-- buildProductInstances = [
				-- SigD       delP  (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) (app2 (ConT $ mkName "RemoveProductType") (VarT with) _T))),
				-- FunD       delP  [Clause [VarP with] (NormalB (AppE (AppE (VarE $ mkName "removeProductType") (VarE with)) (SigE undef _T))) []],
				
				-- SigD       addP  (ForallT [PlainTV without] [ClassP (mkName "OutProductType") [VarT without, _T]] (app2 ArrowT (VarT without) (app2 ArrowT _T (app2 (ConT $ mkName "AddProductType") (VarT without) _T)))),
				-- ValD (VarP addP) (NormalB (VarE $ mkName "addProductType")) [],
				
				-- SigD       setP  (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) (app2 ArrowT _T (VarT with)))),
				-- ValD (VarP setP) (NormalB (VarE $ mkName "setProductType")) [],
				
				-- SigD       getP  (ForallT [PlainTV with] [_HasProductType [VarT with, _T]] (app2 ArrowT (VarT with) _T)),
				-- FunD       getP  [Clause [VarP with] (NormalB (AppE (AppE (VarE $ mkName "getProductType") (VarE with)) (SigE undef _T))) []]
			-- ]
		
		-- -- Helper function.
		-- app2 a b c = AppT (AppT a b) c
		-- t = nameBase new
		
		-- -- Mostly helpful names.
		-- undef = VarE $ mkName "undefined"
		
		-- with = mkName "with"
		-- without = mkName "without"
		
		-- _T = ConT new
		
		-- -- "Product" helpful names.
		-- _HasProductType = ClassP $ mkName "InProductType"
		
		-- setP = mkName $ "setProduct" ++ t
		-- getP = mkName $ "getProduct" ++ t
		-- addP = mkName $ "addProduct" ++ t
		-- delP = mkName $ "removeProduct" ++ t

class ReorderableProduct a

[reorderer|ReorderableProduct
	removeProduct??? :: (InProductType with ???) => with -> RemoveProductType with ???
	removeProduct??? with = removeProductType with (undefined :: ???)
	
	addProduct??? :: (OutProductType without ???) => ??? -> without -> AddProductType without ???
	addProduct??? a b = addProductType b a
	
	setProduct??? :: (InProductType with ???) => ??? -> with -> with
	setProduct??? a b = setProductType b a
	
	getProduct??? :: (InProductType with ???) => with -> ???
	getProduct??? with = getProductType with (undefined :: ???)
|]