{-
	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 TemplateHaskell        #-}

module Data.Types.Reorder.Quoter (
		reorderer
	) where

import Data.Maybe (mapMaybe)

import Data.Types.Reorder.Base

import Language.Haskell.TH
import Language.Haskell.TH.Quote

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

reorderer :: QuasiQuoter
reorderer = QuasiQuoter {
		quoteExp  = error "quoteExp is not defined for \"reorder\".",
		quotePat  = error "quoteExp is not defined for \"reorder\".",
		quoteType = error "quoteExp is not defined for \"reorder\".",
		quoteDec  =
			let
				appT3 c x y z = AppT (AppT (AppT c x) y) z
				numTyLit = LitT . NumTyLit
				strTyLit = LitT . StrTyLit
			in
				return . (\ (t : ds) -> zipWith 
					(\ num d -> InstanceD [] (appT3 (ConT ''ReorderableInstance) (ConT $ mkName t) (numTyLit num) (strTyLit d)) [])
					[0 .. ] ds
				) . mapMaybe trim . map removeLineComments . lines . removeBlockComments
	}

trim :: String -> Maybe String
trim str
		-- This pattern appears to miss the case of just one character, which is
		-- less than ' ', but that case cannot happen because the "dropWhile"
		-- will remove that one character, leaving nothing.
		| rem == []       = Nothing
		| last rem <= ' ' = Just $ init rem
		| otherwise       = Just rem
	where
		rem = dropWhile (<= ' ') str

-- These functions are not perfect.  I don't know if it would be better to just
-- leave haskell-src-meta to sort out the comments.  For example, this will give
-- the wrong result:
--  
--  i |-- 7
--  
-- Here "|--" is an operator, whereas this will strip off everything after "|"
-- as a comment.
removeBlockComments = findStart
	where
		findStart [] = []
		findStart ('{' : '-' : rest) = findStart (findEnd rest)
		findStart (r : rest) = r : findStart rest
		findEnd [] = error "Invalid comment."
		findEnd ('-' : '}' : rest) = rest
		findEnd ('{' : '-' : rest) = findEnd (findEnd rest)
		findEnd (r : rest) = findEnd rest

removeLineComments [] = []
removeLineComments ('-' : '-' : _) = []
removeLineComments (r : rest) = r : removeLineComments rest