module TupleInst where
	import Language.Haskell.TH
	import Language.Haskell.TH.Syntax

	-- === General helper functions for type generation ===

	{-
	 - genT:
	 -
	 - Takes a string s and a number n and returns a list of TH representation types in the
	 - form of [s1, s2, ... sn]
	 -}

	genT s n = [ varT(mkName (s++(show i))) | i <- [1..n] ]

	{-
	 - genTString:
	 -
	 - Performs the same operation as genT but just returns strings.
	 -}

	genTString s n = [ (s++(show i)) | i <- [1..n] ]

	{-
	 - genPE:
	 -
	 - Performs the same operation as genT but returns a double of pattern and expression lists rather
	 - than just the one list of types.
	 -}

	genPE s n = 
		let
			ns = [ s++(show i) | i <- [1..n] ]
		in
			((map (varP . mkName) ns), (map (varE . mkName) ns))
	
	{-
	 - createTupType:
	 -
	 - Takes a list of types and returns them as the TH representation of a tuple.  A list of types in the
	 - form of [t1, t2, t3, t4] would result in the representation for the tuple (t1, t2, t3, t4) being
	 - returned.
	 -}
	
	createTupType typeList = doCreateTupType (reverse typeList) (length typeList)

	{-
	 - doCreateTupType:
	 -
	 - Performs the operations for createTupType.
	 -}

	doCreateTupType [x] tupSize = appT (tupleT tupSize) x
	doCreateTupType (x:xs) tupSize = appT (doCreateTupType xs tupSize) x

	-- === Read instantiation functions ===

	{-
	 - genTupleReadInst:
	 -
	 - Takes the size of a tuple and returns an AST for the code to instantiate tuples of that size
	 - in the Read type class.  For example, the code generated for a triple would be:
	 -
	 - instance (Read a1, Read a2, Read a3) => Read (a1, a2, a3) where
	 -   readsPrec p = readParen False
	 -     (\r1 -> [((b1, b2, b3), r8) | ("(", r2) <- lex r1
	 -                                   (b1, r3) <- reads r2
	 -									 (",", r4) <- lex r3
	 -									 (b2, r5) <- reads r4
	 -									 (",", r6) <- lex r5
	 -									 (b3, r7) <- reads r6
	 -									 (")", r8) <- lex r7 ])
	 -}

	genTupleReadInst tSize = 
		let
			aTs = genT "a" tSize
			instDec = map (appT (conT (mkName "Read"))) aTs
			readTup = appT (conT (mkName "Read")) (createTupType aTs)
			funDec = [(genReadsPrec tSize)]
		in
			sequenceQ [instanceD (cxt instDec) readTup funDec]

	{-
	 - genReadsPrec:
	 -
	 - Generates the readsPrec function for a tuple of a given size specified by the parameter noOfArgs.
	 -}

	genReadsPrec noOfArgs = 
		let
			(pBs, eBs) = genPE "b" noOfArgs
			(pRs, eRs) = genPE "r" ((noOfArgs * 2) + 2)
			funBody = genReadsPrecBody pBs eBs pRs eRs
			funClause = [clause [varP (mkName "p")] funBody []]
		in
			funD (mkName "readsPrec") funClause

	{-
	 - genReadsPrecBody:
	 -
	 - Generates the actual body (the list comprehension for parsing each section and making it an element
	 - of the tuple) for the readsPrec function.
	 -}

	genReadsPrecBody pBs eBs pRs eRs = 
		let
			noBind = noBindS (tupE [(tupE eBs), eRs!!((length eRs) - 1)])
			binds = (bindS (tupP [litP (stringL "("), pRs!!1]) [| lex $(head eRs) |]):(genReadsPrecBinds pBs (tail (tail pRs)) (tail eRs) noBind)
			lam = lamE ([head pRs]) (compE binds)
		in
			normalB [| readParen False $lam |]

	{-
	 - genReadsPrecBinds:
	 -
	 - Generates the
	 -
	 - ("(", r2) <- lex r1
	 - (b1, r3) <- reads r2
	 - ...
	 -
	 - Section of the readsPrec function.
	 -}

	genReadsPrecBinds x (p1:p2:ps) (e1:e2:es) noBind =
		let
			stringLit = litP (stringL (if ((length x) == 1) then ")" else ","))
			bind1 = bindS (tupP [(head x), p1]) [| reads $e1 |]
			bind2 = bindS (tupP [stringLit, p2]) [| lex $e2 |]
		in
			case x of
				[x] -> bind1:bind2:noBind:[]
				(x:xs) -> bind1:bind2:(genReadsPrecBinds xs ps es noBind)

	-- === Show instantiation functions ===

	{-
	 - genTupleShowInst:
	 -
	 - Takes the size of a tuple and returns the instantiation for tuples of that size in the Show
	 - type class.
	 -
	 - instance (Show a1, Show a2, Show a3) => Show (a1, a2, a3) where
	 -   showsPrec p (b1, b2, b3) =
	 -     showsChar '(' . shows b1 . showChar ',' .
	 -     shows b2 . showChar ',' .
	 -	   shows b3 . showChar ')'
	 -}

	genTupleShowInst tSize = 
		let
			aTs = genT "a" tSize
			instDec = map (appT (conT (mkName "Show"))) aTs
			showTup = appT (conT (mkName "Show")) (createTupType aTs)
			funDec = [(genShowsPrec tSize)]
		in
			sequenceQ [instanceD (cxt instDec) showTup funDec]
	
	{-
	 - genShowsPrec:
	 -
	 - Generates the showsPrec function for showing a noOfArgs sized tuple.
	 -}
	
	genShowsPrec noOfArgs = 
		let
			(pBs, eBs) = genPE "b" noOfArgs
			tuplePat = tupP pBs
			funArgs = [(varP (mkName "p")), tuplePat]
			funBody = normalB [| showChar '(' . $(genShowsPrecBody eBs) |]
			funClause = [clause funArgs funBody []]
		in
			funD (mkName "showsPrec") funClause
	
	{-
	 - genShowsPrecBody:
	 -
	 - Generates the body (all the "shows bx . shows ','" pairs) for the showsPrec function.
	 -}
	
	genShowsPrecBody [x] = [| shows $x . showChar ')' |]
	genShowsPrecBody (x:xs) = [| shows $x . showChar ',' . $(genShowsPrecBody xs) |]

	-- === Enum instantiation functions ===

	{-
	 - genEnumInst:
	 -
	 - Takes the size of a tuple and returns a declaration for tuples of that size in the Enum type-class.
	 - For example, for a triple the syntax tree for the following declaration would be returned:
	 -
	 - instance (Enum a1, Enum a2, Enum a3, Bounded a1, Bounded a2, Bounded a3) =>
	 -   Enum (a1, a2, a3) where
	 -     toEnum p =
	 -       let
	 -		   p1 = ((mod p ((fromEnum (maxBound :: a3)) + 1)), (div p ((fromEnum (maxBound :: a3)) + 1)))
	 -		   p2 = ((mod (snd p1) ((fromEnum (maxBound :: a2)) + 1)), (div (snd p1) ((fromEnum (maxBound :: a2)) + 1)))
	 -		   p3 = ((mod (snd p2) ((fromEnum (maxBound :: a1)) + 1)), (div (snd p2) ((fromEnum (maxBound :: a1)) + 1)))
	 - 		 in
	 -		   (toEnum (fst p3), toEnum (fst p2), toEnum (fst p1))
	 -	   fromEnum (b1, b2, b3) =
	 -	     let
	 -		   v1 = fromEnum b1
	 -		   v2 = (v1 * ((fromEnum (maxBound :: a2)) + 1)) + (fromEnum b2)
	 -		   v3 = (v2 * ((fromEnum (maxBound :: a3)) + 1)) + (fromEnum b3)
	 -		 in
	 -		   v3
	 -
	 - Because of the need for scoped variable types in this declaration, every time something is compiled using
	 - one of the generated Enum instantiations the flag -fglasgow-exts must be used.
	 -}

	genTupleEnumInst tSize = 
		let
			tAs = genT "a" tSize
			sAs = genTString "a" tSize
			instDec = (map (appT (conT (mkName "Enum"))) tAs)++(map (appT (conT (mkName "Bounded"))) tAs)
			enumTup = appT (conT (mkName "Enum")) (createTupType tAs)
			toEnumFun = genToEnum tSize sAs
			fromEnumFun = genFromEnum tSize sAs
			funDecs = [toEnumFun, fromEnumFun]
		in
			sequenceQ [instanceD (cxt instDec) enumTup funDecs]

	{-
	 - mbEnum:
	 -
	 - Takes a variable name (always a the name of a type variable) and returns an AST for fromEnum of the
	 - maxBound of that type.  For example, if the variable name was a the returned value would be the AST
	 - for fromEnum (maxBound :: a)
	 -}

	mbEnum ts = [| fromEnum $(sigE [| maxBound |] (conT (mkName ts))) |]

	{-
	 - genPFuns:
	 -
	 - Generates the p values which are used by toEnum (see the example of what genEnumInst generates).
	 -}

	genPFuns _ [] = []
	genPFuns 1 (t:ts) =
		let
			nVar = varE (mkName "p")
			mVal = [| $(mbEnum t) + 1 |]
			bod = [| (mod $nVar $mVal, div $nVar $mVal) |]
			np = valD (varP (mkName "p1")) (normalB bod) []
		in
			np:(genPFuns 2 ts)
	genPFuns n (t:ts) = 
		let
			nVar = [| snd $(varE (mkName ("p"++(show (n - 1))))) |]
			mVal = [| $(mbEnum t) + 1 |]
			bod = [| (mod $nVar $mVal, div $nVar $mVal) |]
			np = valD (varP (mkName ("p"++(show n)))) (normalB bod) []
		in
			np:(genPFuns (n + 1) ts)

	{-
	 - genVFuns:
	 -
	 - Generates the v functions which are used by fromEnum (see the example of what genEnumInst generates).
	 -}

	genVFuns _ [] [] = []
	genVFuns 1 (t:ts) (a:as) =
		let
			nv = valD (varP (mkName "v1")) (normalB (appE [| fromEnum |] (varE (mkName "v1")))) []
		in
			nv:(genVFuns 2 ts as)
	genVFuns n (t:ts) (a:as) = 
		let
			mVal = [| $(mbEnum t) + 1 |]
			bod = [| $(varE (mkName ("v"++(show (n - 1))))) * $mVal + (fromEnum $a) |]
			nv = valD (varP (mkName ("v"++(show n)))) (normalB bod) []
		in
			nv:(genVFuns (n + 1) ts as)

	{-
	 - genToEnum:
	 -
	 - Performs the generation of the toEnum function for a given sized tuple and the given type
	 - variables.
	 -}

	genToEnum noOfArgs tList =
		let
			(_, eBs) = genPE "b" noOfArgs
			fTup = map (appE [| (toEnum . fst) |]) eBs
			funArg = [varP (mkName "p")]
			funBody = normalB (letE (genPFuns 1 tList) (tupE fTup))
			funClause = [clause funArg funBody []]
		in
			funD (mkName "toEnum") funClause

	{-
	 - genFromEnum:
	 -
	 - Performs the generation of the fromEnum function for a given sized tuple and the given type.
	 -}

	genFromEnum noOfArgs tList =
		let
			(pBs, eBs) = genPE "b" noOfArgs
			funArgs = [tupP pBs]
			funBody = normalB (letE (genVFuns 1 tList eBs) (head (reverse eBs)))
			funClause = [clause funArgs funBody []]
		in
			funD (mkName "fromEnum") funClause

	-- === Bounded instantiation function ===

	{-
	 - genTupleBoundedInst:
	 -
	 - Takes a tuple size and returns a declaration for tuples of that size in the Bounded type class.  For example,
	 - if given the argument 3 the return value would be the AST for:
	 -
	 - instance (Bounded a1, Bounded a2, Bounded a3) =>
	 -   Bounded (a1, a2, a3) where
	 -     maxBound = (maxBound :: a1, maxBound :: a2, maxBound :: a3)
	 -     minBound = (minBound :: a1, minBound :: a2, minBound :: a3)
	 -}
		   
	genTupleBoundedInst tSize = 
		let
			tAs = genT "a" tSize
			sAs = genTString "a" tSize
			instDec = (map (appT (conT (mkName "Bounded"))) tAs)
			boundedTup = appT (conT (mkName "Bounded")) (createTupType tAs)
			maxTup = tupE [ sigE [| maxBound |] (varT (mkName (sAs!!i))) | i <- [0..((length sAs) - 1)] ]
			minTup = tupE [ sigE [| minBound |] (varT (mkName (sAs!!i))) | i <- [0..((length sAs) - 1)] ]
			maxVar = valD (varP (mkName "maxBound")) (normalB maxTup) []
			minVar = valD (varP (mkName "minBound")) (normalB minTup) []
			varDecs = [maxVar, minVar]
		in
			sequenceQ [instanceD (cxt instDec) boundedTup varDecs]