implementation module CleanPrettyPrinter

import syntax

from PPrint import	class Pretty(..), ::Doc, ::SimpleDoc, <->, </>, <$>, align, brackets, comma, display, empty, fill, fillSep, 
					hang, hcat, hsep, lbrace, linebreak, nest, parens, punctuate, rbrace, renderPretty, text, tupled, vsep

instance Pretty AType where
	pretty atype = printAType False atype 
	
instance Pretty ATypeVar where
	pretty {atv_variable} = pretty atv_variable

printAType :: !Bool !AType  -> Doc
printAType withParens atype = printType withParens atype.at_type

instance Pretty BasicType where
	pretty bt = text (toString bt)

instance Pretty DefinedSymbol where
	pretty {ds_ident} = pretty ds_ident

instance Pretty (Global a) | Pretty a where
	pretty { Global | glob_object = obj} = pretty obj

instance Pretty Ident where
	pretty {id_name} = text id_name

instance Pretty ParsedConstructor where
	pretty { pc_cons_ident, pc_arg_types }
		= fillSep [ pretty pc_cons_ident : map pretty pc_arg_types ]
	
instance Pretty ParsedSelector
where
	pretty ps = printSelector 0 ps

printSelector :: !Int !ParsedSelector -> Doc
printSelector len {ps_field_ident, ps_field_type } = fill len (pretty ps_field_ident) </> text "::" </> pretty ps_field_type

instance Pretty ParsedTypeDef where
	pretty { td_ident, td_args, td_rhs } = text "::" </> pretty td_ident </> hsep (map pretty td_args) </> pretty td_rhs

instance Pretty RhsDefsOfType where
	pretty (ConsList constructors) 
		= text "=" </> hang -2 (vsep [pretty (hd constructors) : [ text "|" </> pretty c \\ c <- tl constructors ]])
	pretty (SelectorList ident typeVars isBoxed selectors) 
		# len = maxList [ size s.ps_field_ident.id_name \\ s <- selectors ]
		= text "=" </> align ((vsep [lbrace </> printSelector len (hd selectors) : [ comma </> printSelector len c \\ c <- tl selectors]]) <$> rbrace)
	pretty (TypeSpec atype) = text ":==" </> pretty atype
	pretty (EmptyRhs _) = empty
	pretty 	_ = text "= ??"

instance Pretty TCClass where
	pretty (TCClass global) = pretty global
	pretty (TCGeneric {gtc_class}) = pretty gtc_class

instance Pretty Type where
	pretty type = printType False type

printType :: !Bool !Type -> Doc
printType withParens (TA ident []) 
	| ident.type_ident.id_name == "_String" = text "String"
printType withParens (TA ident []) = pretty ident
printType withParens (TA ident [param])
	| ident.type_ident.id_name == "_List" = brackets (pretty param)
printType withParens (TA ident params)
	| ident.type_ident.id_name % (0,5) == "_Tuple" = parens (intersperse comma (map (printAType False) params))
printType withParens (TA ident params) 
	= (if withParens parens id) (fillSep [pretty ident : map (printAType True) params])
printType withParens (TAS ident params _)
	= printType withParens (TA ident params) // skip strictness annotations
printType withParens (TV tv) = pretty tv
printType withParens (--> a b) = parens (pretty a </> text "->" </> pretty b)
printType withParens (TB bt) = pretty bt
printType _ _ = text "(unknown type)"

instance Pretty TypeContext where
	pretty { tc_class, tc_types } = pretty tc_class </> intersperse comma (map (printType False) tc_types)

instance Pretty [TypeContext] where
	pretty [] = empty
	pretty tcs = text "|" </> intersperse (text " & ") (map pretty tcs) 

instance Pretty TypeSymbIdent where
	pretty {type_ident} = pretty type_ident

instance Pretty TypeVar where
	pretty {tv_ident} = pretty tv_ident

intersperse :: Doc [Doc] -> Doc
intersperse sep xs = hcat (punctuate sep xs)

prettyPrint :: Int a -> String | Pretty a
prettyPrint width x = display (renderPretty 0.9 width (nest 4 (pretty x)))

instance Pretty Doc where
	pretty doc = doc