[Haskell-cafe] Re: A thought about liberating Haskell's syntax

[George Pollard]

Just occurred to me that you can actually do this with a preprocessor.
If we extract the "template" declarations to a separate module, then
it can happen something like this (I have corrected some errors in the
above code):

---- main.hs ----

import Language.Haskell.TH
import QList
import Control.Monad

{-

pretend we had this:

main = do
	print (1,2,3)
	print (1)
	print (1,(2,3))
	print ((1,2),3)

- "template_outfix_lparen_rparen_expression" matches normal parens in
the expression context
- we also have a template operator for commas

The rules for the preprocessor are: inputs to the templates are always
wrapped in [| |].
The templates are wrapped in $().

This explains some of the extraneous nesting below (trying to pretend
I'm a machine!)

-}

main = do
	print $(
	 template_outfix_lparen_rparen_expression `fmap` [|
	  $( comma `fmap` [| 1 |] `ap` (comma `fmap` [| 2 |] `ap` [| 3 |]) )
	 |])
	print $(
	 template_outfix_lparen_rparen_expression `fmap` [|
	  $( [| 1 |] )
	 |])
	print $(
	 template_outfix_lparen_rparen_expression `fmap` [|
	  $( comma `fmap` [| 1 |] `ap` [|
	  	$(template_outfix_lparen_rparen_expression `fmap` [| $( comma
`fmap` [| 2 |] `ap` [| 3 |]) |] ) |] )
	 |])
	print $(
	 template_outfix_lparen_rparen_expression `fmap` [|
	  $( comma `fmap` [| $( template_outfix_lparen_rparen_expression
`fmap` [| $(comma `fmap` [| 1 |] `ap` [| 2 |]) |] ) |]
	  	`ap` [| 3 |]  )
	 |])

---------------------- QList.hs -------------------------------
{-
contains the templates and QList.
(the module created by preprocessor would usually only include
templates, with QList being a helper module)
-}

module QList
where
import Debug.Trace
import Language.Haskell.TH

data QList a = QCons a (QList a) | QNil

comma :: Exp → Exp → Exp
a `comma` b@(AppE (AppE (ConE x) _) _)
	| x == qconsName = a `qcons` b
	| otherwise      = a `qcons` (b `qcons` qnil)
a `comma` b = a `qcons` (b `qcons` qnil)

qnil :: Exp
qnil = ConE (mkName "QNil")

qcons :: Exp → Exp → Exp
a `qcons` b = (ConE (mkName "QCons")) `AppE` a `AppE` b

template_outfix_lparen_rparen_expression :: Exp → Exp
template_outfix_lparen_rparen_expression x = case x of
	(AppE (AppE (ConE y) _) _) → if y == qconsName
		then TupE $ fromQList x
		else x
	_                 → x

fromQList :: Exp → [Exp]
fromQList (AppE (AppE (ConE c) h) t)
	| c == qconsName = h:fromQList t
	| otherwise      = error "malformed qlist (head)"
fromQList (ConE n)
	| n == mkName "QNil" = []
	| otherwise = error "malformed qlist (tail)"

qconsName = mkName "QCons"