```module Language.Haskell.Exts.Annotated.ExactPrint
( exactPrint
, ExactP
) where

-- import Debug.Trace (trace)

------------------------------------------------------
-- The EP monad and basic combinators

type Pos = (Int,Int)

pos :: (SrcInfo si) => si -> Pos
pos ss = (startLine ss, startColumn ss)

newtype EP x = EP (Pos -> [Comment] -> (x, Pos, [Comment], ShowS))

return x = EP \$ \l cs -> (x, l, cs, id)

EP m >>= k = EP \$ \l0 c0 -> let
(a, l1, c1, s1) = m l0 c0
EP f = k a
(b, l2, c2, s2) = f l1 c1
in (b, l2, c2, s1 . s2)

runEP :: EP () -> [Comment] -> String
runEP (EP f) cs = let (_,_,_,s) = f (1,1) cs in s ""

getPos :: EP Pos
getPos = EP (\l cs -> (l,l,cs,id))

setPos :: Pos -> EP ()
setPos l = EP (\_ cs -> ((),l,cs,id))

printString :: String -> EP ()
printString str = EP (\(l,c) cs -> ((), (l,c+length str), cs, showString str))

getComment :: EP (Maybe Comment)
getComment = EP \$ \l cs ->
let x = case cs of
c:_ -> Just c
_   -> Nothing
in (x, l, cs, id)

dropComment :: EP ()
dropComment = EP \$ \l cs ->
let cs' = case cs of
(_:cs) -> cs
_      -> cs
in ((), l, cs', id)

newLine :: EP ()
newLine = do
(l,_) <- getPos
printString "\n"
setPos (l+1,1)

padUntil :: Pos -> EP ()
(l1,c1) <- getPos
case  {- trace (show ((l,c), (l1,c1))) -} () of
_ | l1 >= l && c1 <= c -> printString \$ replicate (c - c1) ' '
| l1 < l             -> newLine >> padUntil (l,c)
| otherwise          -> return ()

mPrintComments :: Pos -> EP ()
mc <- getComment
case mc of
Nothing -> return ()
Just (Comment multi s str) ->
when (pos s < p) \$ do
dropComment
printComment multi str
setPos (srcSpanEndLine s, srcSpanEndColumn s)

printComment :: Bool -> String -> EP ()
printComment b str
| b         = printString \$ "{-" ++ str ++ "-}"
| otherwise = printString \$ "--" ++ str

printWhitespace :: Pos -> EP ()

printStringAt :: Pos -> String -> EP ()
printStringAt p str = printWhitespace p >> printString str

------------------------------------------------------------------------------
-- Printing of source elements

exactPrint :: (ExactP ast) => ast L -> [Comment] -> String
exactPrint ast cs = runEP (exactP ast) cs

exactPC :: (Annotated ast, ExactP ast) => ast L -> EP ()
exactPC ast = let p = pos (ann ast) in mPrintComments p >> padUntil p >> exactP ast

printSeq :: [(Pos, EP ())] -> EP ()
printSeq [] = return ()
printSeq ((p,pr):xs) = printWhitespace p >> pr >> printSeq xs

printStrs :: SrcInfo si => [(si, String)] -> EP ()
printStrs = printSeq . map (\(si, str) -> (pos si, printString str))

printPoints :: L -> [String] -> EP ()
printPoints l = printStrs . zip (srcInfoPoints l)

printInterleaved, printInterleaved' :: (Annotated ast, ExactP ast, SrcInfo si) => [(si, String)] -> [ast L] -> EP ()
printInterleaved sistrs asts = printSeq \$
interleave (map (\(si, str) -> (pos si, printString str)) sistrs)
(map (\a -> (pos \$ ann a, exactP a)) asts)

printInterleaved' sistrs (a:asts) = exactPC a >> printInterleaved sistrs asts

printStreams :: [(Pos, EP ())] -> [(Pos, EP ())] -> EP ()
printStreams [] ys = printSeq ys
printStreams xs [] = printSeq xs
printStreams (x@(p1,ep1):xs) (y@(p2,ep2):ys)
| p1 <= p2 = printWhitespace p1 >> ep1 >> printStreams xs (y:ys)
| otherwise = printWhitespace p2 >> ep2 >> printStreams (x:xs) ys

interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave xs [] = xs
interleave (x:xs) (y:ys) = x:y: interleave xs ys

maybeEP :: (a -> EP ()) -> Maybe a -> EP ()
maybeEP = maybe (return ())

bracketList :: (Annotated ast, ExactP ast) => (String, String, String) -> [SrcSpan] -> [ast L] -> EP ()
bracketList (a,b,c) poss asts = printInterleaved (pList poss (a,b,c)) asts

pList (p:ps) (a,b,c) = (p,a) : pList' ps (b,c)
pList' [] _ = []
pList' [p] (_,c) = [(p,c)]
pList' (p:ps) (b,c) = (p, b) : pList' ps (b,c)

parenList, squareList, curlyList :: (Annotated ast, ExactP ast) => [SrcSpan] -> [ast L] -> EP ()
parenList = bracketList ("(",",",")")
squareList = bracketList ("[",",","]")
curlyList = bracketList ("{",",","}")

layoutList :: (Functor ast, Show (ast ()), Annotated ast, ExactP ast) => [SrcSpan] -> [ast L] -> EP ()
layoutList poss asts = printInterleaved (lList poss) asts

lList (p:ps) = (if isNullSpan p then (p,"") else (p,"{")) : lList' ps
lList' [] = []
lList' [p] = [if isNullSpan p then (p,"") else (p,"}")]
lList' (p:ps) = (if isNullSpan p then (p,"") else (p,";")) : lList' ps

type L = SrcSpanInfo

--------------------------------------------------
-- Exact printing

class ExactP ast where
exactP :: ast L -> EP ()

instance ExactP Literal where
exactP lit = case lit of
Char       _ _ rw -> printString ('\'':rw ++ "\'")
String     _ _ rw -> printString ('\"':rw ++ "\"")
Int        _ _ rw -> printString (rw)
Frac       _ _ rw -> printString (rw)
PrimInt    _ _ rw -> printString (rw ++ "#" )
PrimWord   _ _ rw -> printString (rw ++ "##")
PrimFloat  _ _ rw -> printString (rw ++ "#" )
PrimDouble _ _ rw -> printString (rw ++ "##")
PrimChar   _ _ rw -> printString ('\'':rw ++ "\'#" )
PrimString _ _ rw -> printString ('\"':rw ++ "\"#" )

instance ExactP ModuleName where
exactP (ModuleName l str) = printString str

instance ExactP SpecialCon where
exactP sc = case sc of
UnitCon l   -> printPoints l ["(",")"]
ListCon l   -> printPoints l ["[","]"]
FunCon  l   -> printPoints l ["(","->",")"]
TupleCon l b n -> printPoints l \$
case b of
Unboxed -> "(#": replicate n "," ++ ["#)"]
_       -> "(" : replicate n "," ++ [")"]
Cons l      -> printString ":"
UnboxedSingleCon l -> printPoints l ["(#","#)"]

isSymbol :: Name l -> Bool
isSymbol (Symbol _ _) = True
isSymbol _ = False

getName :: QName l -> Name l
getName (UnQual _ s) = s
getName (Qual _ _ s) = s
getName (Special l (Cons _)) = Symbol l ":"
getName (Special l (FunCon _)) = Symbol l "->"
getName (Special l s) = Ident l (specialName s)

specialName :: SpecialCon l -> String
specialName (UnitCon _) = "()"
specialName (ListCon _) = "[]"
specialName (FunCon  _) = "->"
specialName (TupleCon _ b n) = "(" ++ hash ++ replicate (n-1) ',' ++ hash ++ ")"
where hash = case b of
Unboxed -> "#"
_       -> ""
specialName (Cons _) = ":"

instance ExactP QName where
exactP qn
| isSymbol (getName qn) = do
let [a,b,c] = srcInfoPoints (ann qn)
printString "("
printWhitespace (pos b)
epQName qn
printStringAt (pos c) ")"
| otherwise = epQName qn

epQName :: QName L -> EP ()
epQName qn = case qn of
Qual    l mn n  -> exactP mn >> printString "." >> epName n
UnQual  l    n  -> epName n
Special l sc    -> exactP sc

epInfixQName :: QName L -> EP ()
epInfixQName qn
| isSymbol (getName qn) = printWhitespace (pos (ann qn)) >> epQName qn
| otherwise = do
let [a,b,c] = srcInfoPoints (ann qn)
printStringAt (pos a) "`"
printWhitespace (pos b)
epQName qn
printStringAt (pos c) "`"

instance ExactP Name where
exactP n = case n of
Ident  l str    -> printString str
Symbol l str    -> do
let [a,b,c] = srcInfoPoints l
printString "("
printWhitespace (pos b)
printString str
printStringAt (pos c) ")"

epName :: Name L -> EP ()
epName (Ident  _ str) = printString str
epName (Symbol _ str) = printString str

epInfixName :: Name L -> EP ()
epInfixName n
| isSymbol n = printWhitespace (pos (ann n)) >> epName n
| otherwise = do
let [a,b,c] = srcInfoPoints (ann n)
printStringAt (pos a) "`"
printWhitespace (pos b)
epName n
printStringAt (pos c) "`"

instance ExactP IPName where
exactP ipn = case ipn of
IPDup l str -> printString \$ '?':str
IPLin l str -> printString \$ '%':str

instance ExactP QOp where
exactP qop = case qop of
QVarOp l qn -> epInfixQName qn
QConOp l qn -> epInfixQName qn

instance ExactP Op where
exactP op = case op of
VarOp l n -> epInfixName n
ConOp l n -> epInfixName n

instance ExactP CName where
exactP cn = case cn of
VarName l n -> exactP n
ConName l n -> exactP n

instance ExactP ExportSpec where
exactP espec = case espec of
EVar l qn      -> exactP qn
EAbs l qn      -> exactP qn
EThingAll l qn -> exactP qn >> printPoints l ["(","..",")"]
EThingWith l qn cns    ->
let k = length (srcInfoPoints l)
in exactP qn >> printInterleaved (zip (srcInfoPoints l) \$ "(":replicate (k-2) "," ++ [")"]) cns
EModuleContents l mn -> printString "module" >> exactPC mn

instance ExactP ExportSpecList where
exactP (ExportSpecList l ess) =
let k = length (srcInfoPoints l)
in printInterleaved (zip (srcInfoPoints l) \$ "(": replicate (k-2) "," ++ [")"]) ess

instance ExactP ImportSpecList where
exactP (ImportSpecList l hid ispecs) = do
let pts = srcInfoPoints l
pts <- if hid then do
let (x:pts') = pts
printStringAt (pos x) "hiding"
return pts'
else return pts
let k = length pts
printInterleaved (zip pts \$ "(": replicate (k-2) "," ++ [")"]) ispecs

instance ExactP ImportSpec where
exactP ispec = case ispec of
IVar l n    -> exactP n
IAbs l n    -> exactP n
IThingAll l n   -> exactP n >> printPoints l ["(","..",")"]
IThingWith l n cns    ->
let k = length (srcInfoPoints l)
in exactP n >> printInterleaved (zip (srcInfoPoints l) \$ "(":replicate (k-2) "," ++ [")"]) cns

instance ExactP ImportDecl where
exactP (ImportDecl l mn qf src mpkg mas mispecs) = do
printString "import"
let (a:pts) = srcInfoPoints l
pts <- if src then do
let (x:y:pts') = pts
printStringAt (pos x) "{-# SOURCE"
printStringAt (pos y) "#-}"
return pts'
else return pts
pts <- if qf then do
let (x:pts') = pts
printStringAt (pos x) "qualified"
return pts'
else return pts
pts <- case mpkg of
Just pkg -> do
let (x:pts') = pts
printStringAt (pos x) \$ show pkg
return pts'
_ -> return pts
exactPC mn
pts <- case mas of
Just as -> do
let (x:pts') = pts
printStringAt (pos x) "as"
exactPC as
return pts'
_ -> return pts
case mispecs of
Nothing -> return ()
Just ispecs -> exactPC ispecs

instance ExactP Module where
exactP mdl = case mdl of
Module l mmh oss ids decls -> do
let (oPts, pts) = splitAt (max (length oss + 1) 2) (srcInfoPoints l)
layoutList oPts oss
maybeEP exactPC mmh
printStreams (map (\(p,s) -> (pos p, printString s)) \$ lList pts)
(map (\i -> (pos \$ ann i, exactPC i)) ids ++ map (\d -> (pos \$ ann d, exactPC d)) (sepFunBinds decls))
{-
XmlPage l [OptionPragma l] (XName l) [XAttr l] (Maybe (Exp l)) [Exp l]

XmlHybrid l (Maybe (ModuleHead l)) [OptionPragma l] [ImportDecl l] [Decl l]
(XName l) [XAttr l] (Maybe (Exp l)) [Exp l]
-}

exactP (ModuleHead l mn mwt mess) = do
let [a,b] = srcInfoPoints l
printStringAt (pos a) "module"
exactPC mn
maybeEP exactPC mwt
maybeEP exactPC mess
printStringAt (pos b) "where"

instance ExactP OptionPragma where
exactP op = case op of
LanguagePragma   l ns       ->
let pts = srcInfoPoints l
k = length ns - 1 -- number of commas
m = length pts - k - 2 -- number of virtual semis, likely 0
in printInterleaved (zip pts ("{-# LANGUAGE":replicate k "," ++ replicate m "" ++ ["#-}"])) ns
IncludePragma    l str      ->
let k = length (srcInfoPoints l)
in printPoints l \$ ("{-# INCLUDE " ++ str) : replicate (k-2) "" ++ ["#-}"]
CFilesPragma     l str      ->
let k = length (srcInfoPoints l)
in printPoints l \$ ("{-# CFILES " ++ str) : replicate (k-2) "" ++ ["#-}"]
OptionsPragma    l mt str   ->
let k = length (srcInfoPoints l)
opstr = "{-# OPTIONS" ++ case mt of { Just t -> "_" ++ show t ; _ -> "" } ++ " " ++ str
in printPoints l \$ opstr : replicate (k-2) "" ++ ["#-}"]

instance ExactP WarningText where
exactP (DeprText l str) = printPoints l ["{-# DEPRECATED", str, "#-}"]
exactP (WarnText l str) = printPoints l ["{-# WARNING",    str, "#-}"]

instance ExactP Assoc where
exactP a = case a of
AssocNone  l -> printString "infix"
AssocLeft  l -> printString "infixl"
AssocRight l -> printString "infixr"

instance ExactP DataOrNew where
exactP (DataType l) = printString "data"
exactP (NewType  l) = printString "newtype"

instance ExactP Decl where
exactP decl = case decl of
TypeDecl     l dh t      -> do
let [a,b] = srcInfoPoints l
printStringAt (pos a) "type"
exactPC dh
printStringAt (pos b) "="
exactPC t
TypeFamDecl  l dh mk     -> do
let (a:b:ps) = srcInfoPoints l
printStringAt (pos a) "type"
printStringAt (pos b) "family"
exactPC dh
maybeEP (\k -> printStringAt (pos (head ps)) "::" >> exactPC k) mk
DataDecl     l dn mctxt dh constrs mder -> do
exactP dn
maybeEP exactPC mctxt
exactPC dh
-- the next line works for empty data types since the srcInfoPoints will be empty then
printInterleaved (zip (srcInfoPoints l) ("=": repeat "|")) constrs
maybeEP exactPC mder
GDataDecl    l dn mctxt dh mk gds mder -> do
let pts = srcInfoPoints l
exactP dn
maybeEP exactPC mctxt
exactPC dh
(x:pts) <- case mk of
Nothing -> return pts
Just kd -> let (p:pts') = pts in do
printStringAt (pos p) "::"
exactPC kd
return pts'
printStringAt (pos x) "where"
layoutList pts gds
maybeEP exactPC mder
DataFamDecl  l mctxt dh mk -> do
printString "data"
maybeEP exactPC mctxt
exactPC dh
maybeEP (\kd -> printStringAt (pos (head (srcInfoPoints l))) "::" >> exactPC kd) mk
TypeInsDecl  l t1 t2 -> do
let [a,b,c] = srcInfoPoints l
printString "type"
printStringAt (pos b) "instance"
exactPC t1
printStringAt (pos c) "="
exactPC t2
DataInsDecl  l dn t constrs mder    -> do
let (p:pts) = srcInfoPoints l
exactP dn
printStringAt (pos p) "instance"
exactPC t
printInterleaved (zip (srcInfoPoints l) ("=": repeat "|")) constrs
maybeEP exactPC mder
GDataInsDecl l dn t mk gds mder     -> do
let (p:pts) = srcInfoPoints l
exactP dn
printStringAt (pos p) "instance"
exactPC t
(x:pts) <- case mk of
Nothing -> return pts
Just kd -> let (p:pts') = pts in do
printStringAt (pos p) "::"
exactPC kd
return pts'
printStringAt (pos x) "where"
layoutList pts gds
maybeEP exactPC mder
ClassDecl    l mctxt dh fds mcds    -> do
let pts = srcInfoPoints l
printString "class"
maybeEP exactPC mctxt
exactPC dh
pts <- case fds of
[] -> return pts
_  -> do
let (pts1, pts2) = splitAt (length fds) pts
printInterleaved (zip pts1 ("|":repeat ",")) fds
return pts2
maybeEP (\cds -> do
let (p:pts') = pts
printStringAt (pos p) "where"
layoutList pts' cds
) mcds
InstDecl     l mctxt ih mids        -> do
let (a:pts) = srcInfoPoints l
printString "instance"
maybeEP exactPC mctxt
exactPC ih
maybeEP (\ids -> do
let (p:pts') = pts
printStringAt (pos p) "where"
layoutList pts' ids
) mids
DerivDecl    l mctxt ih             -> do
let [a,b] = srcInfoPoints l
printString "deriving"
printStringAt (pos b) "instance"
maybeEP exactPC mctxt
exactPC ih
InfixDecl    l assoc mprec ops      -> do
let pts = srcInfoPoints l
exactP assoc
pts <- case mprec of
Nothing -> return pts
Just prec -> do
let (p:pts') = pts
printStringAt (pos p) (show prec)
return pts'
printInterleaved' (zip pts (repeat ",")) ops
DefaultDecl  l ts   -> do
let (a:pts) = srcInfoPoints l
printString "default"
printInterleaved (zip (init pts) ("(":repeat ",")) ts
printStringAt (pos (last pts)) ")"
SpliceDecl   l spl  -> exactP spl
TypeSig      l ns t -> do
let pts = srcInfoPoints l
printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns
exactPC t
FunBind      l ms   -> mapM_ exactPC ms
PatBind      l p mt rhs mbs -> do
let pts = srcInfoPoints l
exactP p
pts <- case mt of
Nothing -> return pts
Just t  -> let (x:pts') = pts in do
printStringAt (pos x) "::"
exactPC t
return pts'
exactPC rhs
maybeEP (\bs -> printStringAt (pos (head pts)) "where" >> exactPC bs) mbs
ForImp       l cc msf mstr n t   -> do
let (a:b:pts) = srcInfoPoints l
printString "foreign"
printStringAt (pos b) "import"
exactPC cc
maybeEP exactPC msf
(y:_) <- case mstr of
Nothing -> return pts
Just str -> let (x:pts') = pts in do
printStringAt (pos x) (show str)
return pts'
exactPC n
printStringAt (pos y) "::"
exactPC t
ForExp       l cc mstr n t      -> do
let (a:b:pts) = srcInfoPoints l
printString "foreign"
printStringAt (pos b) "export"
exactPC cc
(y:_) <- case mstr of
Nothing -> return pts
Just str -> let (x:pts') = pts in do
printStringAt (pos x) (show str)
return pts'
exactPC n
printStringAt (pos y) "::"
exactPC t
let [a,b] = srcInfoPoints l
printString "{-# RULES"
mapM_ exactPC rs
printStringAt (pos b) "#-}"
let pts = srcInfoPoints l
printString "{-# DEPRECATED"
printWarndeprs (map pos (init pts)) nstrs
printStringAt (pos (last pts)) "#-}"
let pts = srcInfoPoints l
printString "{-# WARNING"
printWarndeprs (map pos (init pts)) nstrs
printStringAt (pos (last pts)) "#-}"
InlineSig        l inl mact qn    -> do
let [a,b] = srcInfoPoints l
printString \$ if inl then "{-# INLINE" else "{-# NOINLINE"
maybeEP exactPC mact
exactPC qn
printStringAt (pos b) "#-}"
SpecSig          l qn ts        -> do
let (a:pts) = srcInfoPoints l
printString "{-# SPECIALISE"
exactPC qn
printInterleaved (zip pts ("::" : repeat "," ++ ["#-}"])) ts
SpecInlineSig    l b mact qn ts -> do
let (a:pts) = srcInfoPoints l
printString \$ "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE"
maybeEP exactPC mact
exactPC qn
printInterleaved (zip pts ("::" : repeat "," ++ ["#-}"])) ts
InstSig          l mctxt ih     -> do
let [a,b,c] = srcInfoPoints l
printString \$ "{-# SPECIALISE"
printStringAt (pos b) "instance"
maybeEP exactPC mctxt
exactPC ih
printStringAt (pos c) "#-}"

printWarndeprs :: [Pos] -> [([Name L], String)] -> EP ()
printWarndeprs _ [] = return ()
printWarndeprs ps ((ns,str):nsts) = printWd ps ns str nsts
where printWd :: [Pos] -> [Name L] -> String -> [([Name L], String)] -> EP ()
printWd (p:ps) []  str nsts = printStringAt p (show str) >> printWarndeprs ps nsts
printWd ps     [n] str nsts = exactPC n >> printWd ps [] str nsts
printWd (p:ps) (n:ns) str nsts = exactPC n >> printStringAt p "," >> printWd ps ns str nsts

sepFunBinds :: [Decl L] -> [Decl L]
sepFunBinds [] = []
sepFunBinds (FunBind _ ms:ds) = map (\m -> FunBind (ann m) [m]) ms ++ sepFunBinds ds
sepFunBinds (d:ds) = d : sepFunBinds ds

exactP dh = case dh of
DHead l n tvs       -> exactP n >> mapM_ exactPC tvs
DHInfix l tva n tvb -> exactP tva >> epInfixName n >> exactPC tvb
DHParen l dh        ->
let [_,b] = srcInfoPoints l
in printString "(" >> exactPC dh >> printStringAt (pos b) ")"

exactP ih = case ih of
IHead l qn ts       -> exactP qn >> mapM_ exactPC ts
IHInfix l ta qn tb  -> exactP ta >> epInfixQName qn >> exactPC tb
IHParen l ih        ->
let [_,b] = srcInfoPoints l
in printString "(" >> exactPC ih >> printStringAt (pos b) ")"

instance ExactP TyVarBind where
exactP (KindedVar   l n k) = do
let [a,b,c] = srcInfoPoints l
printString "("
exactPC n
printStringAt (pos b) "::"
exactPC k
printStringAt (pos c) ")"
exactP (UnkindedVar l n) = exactP n

instance ExactP Kind where
exactP kd = case kd of
KindStar  l     -> printString "*"
KindBang  l     -> printString "!"
KindFn    l k1 k2 -> do
let [a] = srcInfoPoints l
exactP k1
printStringAt (pos a) "->"
exactPC k2
KindParen l kd  -> do
let [a,b] = srcInfoPoints l
printString "("
exactPC kd
printStringAt (pos b) ")"

instance ExactP Type where
exactP t = case t of
TyForall l mtvs mctxt t -> do
let pts = srcInfoPoints l
pts <- case mtvs of
Nothing -> return pts
Just tvs -> do
let (a:b:pts') = pts
printString "forall"
mapM_ exactPC tvs
printStringAt (pos b) "."
return pts'
maybeEP exactPC mctxt
exactPC t
TyFun   l t1 t2 -> do
let [a] = srcInfoPoints l
exactP t1
printStringAt (pos a) "->"
exactPC t2
TyTuple l bx ts -> do
let pts = srcInfoPoints l
(o,e) = case bx of
Boxed   -> ("(" , ")")
Unboxed -> ("(#","#)")
printInterleaved (zip pts (o: replicate (length pts - 2) "," ++ [e])) ts
TyList  l t     -> do
let [a,b] = srcInfoPoints l
printString "["
exactPC t
printStringAt (pos b) "]"
TyApp   l t1 t2 -> exactP t1 >> exactPC t2
TyVar   l n     -> exactP n
TyCon   l qn    -> exactP qn
TyParen l t     -> do
let [a,b] = srcInfoPoints l
printString "("
exactPC t
printStringAt (pos b) ")"
TyInfix l t1 qn t2 -> exactP t1 >> epInfixQName qn >> exactPC t2
TyKind  l t kd -> do
let [a,b,c] = srcInfoPoints l
printString "("
exactPC t
printStringAt (pos b) "::"
exactPC kd
printStringAt (pos c) ")"

instance ExactP Context where
exactP ctxt = do
printContext ctxt
printStringAt (pos (last (srcInfoPoints (ann ctxt)))) "=>"

printContext ctxt = do
let l = ann ctxt
pts = init \$ srcInfoPoints l
case ctxt of
CxParen l ctxt -> do
let [a,b] = pts
printStringAt (pos a) "("
printContext ctxt
printStringAt (pos b) ")"
CxSingle l asst -> exactP asst
CxEmpty l -> do
let [a,b] = pts
printStringAt (pos a) "("
printStringAt (pos b) ")"
CxTuple l assts -> parenList pts assts

instance ExactP Asst where
exactP asst = case asst of
ClassA l qn ts -> exactP qn >> mapM_ exactPC ts
InfixA l ta qn tb -> exactP ta >> epInfixQName qn >> exactPC tb
IParam l ipn t    -> do
let [a] = srcInfoPoints l
exactP ipn
printStringAt (pos a) "::"
exactPC t
EqualP l t1 t2  -> do
let [a] = srcInfoPoints l
exactP t1
printStringAt (pos a) "~"
exactPC t2

instance ExactP Deriving where
exactP (Deriving l ihs) = do
let (x:pts) = srcInfoPoints l
printString "deriving"
parenList pts ihs

instance ExactP ClassDecl where
exactP cdecl = case cdecl of
ClsDecl    l d -> exactP d
ClsDataFam l mctxt dh mk -> do
let (x:pts) = srcInfoPoints l
printString "data"
maybeEP exactPC mctxt
exactPC dh
maybeEP (\kd -> printStringAt (pos (head pts)) "::" >> exactPC kd) mk
ClsTyFam   l dh mk  -> do
let (x:pts) = srcInfoPoints l
printString "type"
exactPC dh
maybeEP (\kd -> printStringAt (pos (head pts)) "::" >> exactPC kd) mk
ClsTyDef   l t1 t2  -> do
let [a,b] = srcInfoPoints l
printString "type"
exactPC t1
printStringAt (pos b) "="
exactPC t2

instance ExactP InstDecl where
exactP idecl = case idecl of
InsDecl   l d -> exactP d
InsType   l t1 t2 -> do
let [a,b] = srcInfoPoints l
printString "type"
exactPC t1
printStringAt (pos b) "="
exactPC t2
InsData   l dn t constrs mder -> do
exactP dn
exactPC t
printInterleaved (zip (srcInfoPoints l) ("=": repeat "|")) constrs
maybeEP exactPC mder
InsGData  l dn t mk gds mder  -> do
let pts = srcInfoPoints l
exactP dn
exactPC t
(x:pts) <- case mk of
Nothing -> return pts
Just kd -> let (p:pts') = pts in do
printStringAt (pos p) "::"
exactPC kd
return pts'
printStringAt (pos x) "where"
mapM_ exactPC gds
maybeEP exactPC mder
InsInline l inl mact qn   -> do
let [a,b] = srcInfoPoints l
printString \$ if inl then "{-# INLINE" else "{-# NOINLINE"
maybeEP exactPC mact
exactPC qn
printStringAt (pos b) "#-}"

instance ExactP FunDep where
exactP (FunDep l nxs nys) = do
let [a] = srcInfoPoints l
mapM_ exactPC nxs
printStringAt (pos a) "->"
mapM_ exactPC nys

instance ExactP QualConDecl where
exactP (QualConDecl l mtvs mctxt cd) = do
let pts = srcInfoPoints l
pts <- case mtvs of
Nothing -> return pts
Just tvs -> do
let (a:b:pts') = pts
printString "forall"
mapM_ exactPC tvs
printStringAt (pos b) "."
return pts'
maybeEP exactPC mctxt
exactPC cd

instance ExactP ConDecl where
exactP cd = case cd of
ConDecl l n bts -> exactP n >> mapM_ exactPC bts
InfixConDecl l bta n btb -> exactP bta >> epInfixName n >> exactP btb
RecDecl l n fds -> exactP n >> curlyList (srcInfoPoints l) fds

exactP (GadtDecl l n t) = do
let [a] = srcInfoPoints l
exactP n
printStringAt (pos a) "::"
exactPC t

instance ExactP BangType where
exactP bt = case bt of
UnBangedTy l t  -> exactP t
BangedTy   l t  -> printString "!" >> exactPC t
UnpackedTy l t  -> do
let [a,b,c] = srcInfoPoints l
printString "{-# UNPACK"
printStringAt (pos b) "#-}"
printStringAt (pos c) "!"
exactPC t

instance ExactP Splice where
exactP (IdSplice l str) = printString \$ '\$':str
exactP (ParenSplice l e) = do
let [a,b] = srcInfoPoints l
printString "\$("
exactPC e
printStringAt (pos b) ")"

instance ExactP Exp where
exactP exp = case exp of
Var l qn        -> exactP qn
IPVar l ipn     -> exactP ipn
Con l qn        -> exactP qn
Lit l lit       -> exactP lit
InfixApp l e1 op e2 -> exactP e1 >> exactPC op >> exactPC e2
App l e1 e2     -> exactP e1 >> exactPC e2
NegApp l e      -> printString "-" >> exactPC e
Lambda l ps e   -> do
let [a,b] = srcInfoPoints l
printString "\\"
mapM_ exactPC ps
printStringAt (pos b) "->"
exactPC e
Let l bs e      -> do
let [a,b] = srcInfoPoints l
printString "let"
exactPC bs
printStringAt (pos b) "in"
exactPC e
If l ec et ee   -> do
let [a,b,c] = srcInfoPoints l
printString "if"
exactPC ec
printStringAt (pos b) "then"
exactPC et
printStringAt (pos c) "else"
exactPC ee
Case l e alts   -> do
let (a:b:pts) = srcInfoPoints l
printString "case"
exactPC e
printStringAt (pos b) "of"
layoutList pts alts
Do l stmts      -> do
let (a:pts) = srcInfoPoints l
printString "do"
layoutList pts stmts
MDo l stmts     -> do
let (a:pts) = srcInfoPoints l
printString "mdo"
layoutList pts stmts
Tuple l es      -> parenList (srcInfoPoints l) es
TupleSection l mexps    -> do
let pts = srcInfoPoints l
printSeq \$ interleave (zip (map pos \$ init pts) (map printString ("(": repeat ",")) ++ [(pos \$ last pts, printString ")")])
(map (\me -> (maybe (0,0) (pos . ann) me, maybeEP exactPC me)) mexps)
List l es               -> squareList (srcInfoPoints l) es
Paren l p               -> parenList (srcInfoPoints l) [p]
LeftSection l e qop     -> do
let [a,b] = srcInfoPoints l
printString "("
exactPC e
exactPC qop
printStringAt (pos b) ")"
RightSection l qop e    -> do
let [a,b] = srcInfoPoints l
printString "("
exactPC qop
exactPC e
printStringAt (pos b) ")"
RecConstr l qn fups     -> do
let pts = srcInfoPoints l
exactP qn
curlyList pts fups
RecUpdate l e fups      -> do
let pts = srcInfoPoints l
exactP e
curlyList pts fups
EnumFrom l e            -> do
let [a,b,c] = srcInfoPoints l
printString "["
exactPC e
printStringAt (pos b) ".."
printStringAt (pos c) "]"
EnumFromTo l e1 e2      -> do
let [a,b,c] = srcInfoPoints l
printString "["
exactPC e1
printStringAt (pos b) ".."
exactPC e2
printStringAt (pos c) "]"
EnumFromThen l e1 e2    -> do
let [a,b,c,d] = srcInfoPoints l
printString "["
exactPC e1
printStringAt (pos b) ","
exactPC e2
printStringAt (pos c) ".."
EnumFromThenTo l e1 e2 e3   -> do
let [a,b,c,d] = srcInfoPoints l
printString "["
exactPC e1
printStringAt (pos b) ","
exactPC e2
printStringAt (pos c) ".."
exactPC e3
printStringAt (pos d) "]"
ListComp l e qss            -> do
let (a:pts) = srcInfoPoints l
printString "["
exactPC e
bracketList ("|",",","]") pts qss
ParComp  l e qsss           -> do
let (a:pts) = srcInfoPoints l
(strs, qss) = unzip \$ pairUp qsss
printString "["
exactPC e
printInterleaved (zip pts (strs ++ ["]"])) qss
where pairUp [] = []
pairUp ((a:as):xs) = ("|", a) : zip (repeat ",") as ++ pairUp xs

ExpTypeSig l e t    -> do
let [a] = srcInfoPoints l
exactP e
printStringAt (pos a) "::"
exactPC t
VarQuote l qn   -> do
printString "'"
exactPC qn
TypQuote l qn -> do
printString "''"
exactPC qn
BracketExp l br -> exactP br
SpliceExp l sp  -> exactP sp
QuasiQuote l name qt    -> printString \$ "[\$" ++ name ++ "|" ++ qt ++ "]"
XTag l xn attrs mat es  -> do
let [a,b,c,d,e] = srcInfoPoints l
printString "<"
exactPC xn
mapM_ exactPC attrs
maybeEP exactPC mat
printStringAt (pos b) ">"
mapM_ exactPC es
printStringAt (pos c) "</"
printWhitespace (pos d)
exactP xn
printStringAt (pos e) ">"
XETag l xn attrs mat    -> do
let [a,b] = srcInfoPoints l
printString "<"
exactPC xn
mapM_ exactPC attrs
maybeEP exactPC mat
printStringAt (pos b) "/>"
XPcdata l str   -> printString str
XExpTag l e     -> do
let [a,b] = srcInfoPoints l
printString "<%"
exactPC e
printString "%>"

CorePragma l      str e         -> do
let [a,b] = srcInfoPoints l
printString \$ "{-# CORE " ++ show str
printStringAt (pos b) "#-}"
exactPC e
SCCPragma  l      str e         -> do
let [a,b] = srcInfoPoints l
printString \$ "{-# SCC " ++ show str
printStringAt (pos b) "#-}"
exactPC e
GenPragma  l      str (i1,i2) (i3,i4) e -> do
printStrs \$ zip (srcInfoPoints l) ["{-# GENERATED", show str, show i1, ":", show i2, "-", show i3, ":", show i4, "#-}"]
exactPC e
Proc            l p e   -> do
let [a,b] = srcInfoPoints l
printString "proc"
exactPC p
printStringAt (pos b) "->"
exactPC e
LeftArrApp      l e1 e2 -> do
let [a] = srcInfoPoints l
exactP e1
printStringAt (pos a) "-<"
exactPC e2
RightArrApp     l e1 e2 -> do
let [a] = srcInfoPoints l
exactP e1
printStringAt (pos a) ">-"
exactPC e2
LeftArrHighApp  l e1 e2 -> do
let [a] = srcInfoPoints l
exactP e1
printStringAt (pos a) "-<<"
exactPC e2
RightArrHighApp l e1 e2 -> do
let [a] = srcInfoPoints l
exactP e1
printStringAt (pos a) ">>-"
exactPC e2

instance ExactP FieldUpdate where
exactP fup = case fup of
FieldUpdate l qn e  -> do
let [a] = srcInfoPoints l
exactP qn
printStringAt (pos a) "="
exactPC e
FieldPun l n    -> exactP n
FieldWildcard l -> printString ".."

instance ExactP Stmt where
exactP stmt = case stmt of
Generator l p e -> do
let [a] = srcInfoPoints l
exactP p
printStringAt (pos a) "<-"
exactPC e
Qualifier l e -> exactP e
LetStmt l bds   -> do
printString "let"
exactPC bds
RecStmt l ss    -> do
let (a:pts) = srcInfoPoints l
printString "rec"
layoutList pts ss

instance ExactP QualStmt where
exactP qstmt = case qstmt of
QualStmt     l stmt -> exactP stmt
ThenTrans    l e    -> printString "then" >> exactPC e
ThenBy       l e1 e2    -> do
let [a,b] = srcInfoPoints l
printString "then"
exactPC e1
printStringAt (pos b) "by"
exactPC e2
GroupBy      l e        -> do
printStrs \$ zip (srcInfoPoints l) ["then","group","by"]
exactPC e
GroupUsing   l e        -> do
printStrs \$ zip (srcInfoPoints l) ["then","group","using"]
exactPC e
GroupByUsing l e1 e2    -> do
let pts = srcInfoPoints l
printStrs \$ zip (init pts) ["then","group","by"]
exactPC e1
printStringAt (pos (last pts)) "using"
exactPC e2

instance ExactP Bracket where
exactP br = case br of
ExpBracket l e  -> do
let [a,b] = srcInfoPoints l
printString "[|"
exactPC e
printStringAt (pos b) "|]"
PatBracket l p  -> do
let [a,b] = srcInfoPoints l
printString "[p|"
exactPC p
printStringAt (pos b) "|]"
TypeBracket l t  -> do
let [a,b] = srcInfoPoints l
printString "[t|"
exactPC t
printStringAt (pos b) "|]"
DeclBracket l ds -> do
let (a:pts) = srcInfoPoints l
printString "[d|"
layoutList (init pts) (sepFunBinds ds)
printStringAt (pos (last pts)) "|]"

instance ExactP XAttr where
exactP (XAttr l xn e) = do
let [a] = srcInfoPoints l
exactP xn
printStringAt (pos a) "="
exactPC e

instance ExactP Alt where
exactP (Alt l p galts mbs) = do
exactP p
exactPC galts
maybeEP (\bs -> printStringAt (pos (head (srcInfoPoints l))) "where" >> exactPC bs) mbs

instance ExactP GuardedAlts where
exactP (UnGuardedAlt l e) = printString "->" >> exactPC e
exactP (GuardedAlts  l galts) = mapM_ exactPC galts

instance ExactP GuardedAlt where
exactP (GuardedAlt l stmts e) = do
bracketList ("|",",","->") (srcInfoPoints l) stmts
exactPC e

instance ExactP Match where
exactP (Match l n ps rhs mbinds) = do
let pts = srcInfoPoints l
exactP n
mapM_ exactPC ps
exactPC rhs
maybeEP (\bds -> printStringAt (pos (head pts)) "where" >> exactPC bds) mbinds
exactP (InfixMatch l a n b rhs mbinds) = do
let pts = srcInfoPoints l
exactP a
epInfixName n
exactPC b
exactPC rhs
maybeEP (\bds -> printStringAt (pos (head pts)) "where" >> exactPC bds) mbinds

instance ExactP Rhs where
exactP (UnGuardedRhs l e) = printString "=" >> exactPC e
exactP (GuardedRhss  l grhss) = mapM_ exactPC grhss

instance ExactP GuardedRhs where
exactP (GuardedRhs l ss e) = do
let (a:pts) = srcInfoPoints l
printString "|"
printInterleaved' (zip (init pts) (repeat ",") ++ [(last pts, "=")]) ss
exactPC e

instance ExactP Pat where
exactP pat = case pat of
PVar l n    -> exactP n
PLit l lit  -> exactP lit
PNeg l p    -> printString "-" >> exactPC p
PNPlusK l n k   -> do
let [a,b] = srcInfoPoints l
exactP n
printStringAt (pos a) "+"
printStringAt (pos b) (show k)
PInfixApp l pa qn pb -> exactP pa >> epInfixQName qn >> exactPC pb
PApp l qn ps    -> exactP qn >> mapM_ exactPC ps
PTuple l ps -> parenList (srcInfoPoints l) ps
PList l ps  -> squareList (srcInfoPoints l) ps
PParen l p  -> parenList (srcInfoPoints l) [p]
PRec l qn pfs   -> exactP qn >> curlyList (srcInfoPoints l) pfs
PAsPat l n p    -> do
let [a] = srcInfoPoints l
exactP n
printStringAt (pos a) "@"
exactPC p
PWildCard l -> printString "_"
PIrrPat l p -> printString "~" >> exactPC p
PatTypeSig l p t -> do
let [a] = srcInfoPoints l
exactP p
printStringAt (pos a) "::"
exactPC t
PViewPat l e p -> do
let [a] = srcInfoPoints l
exactP e
printStringAt (pos a) "->"
exactPC p
PRPat l rps -> squareList (srcInfoPoints l) rps
PXTag l xn attrs mat ps -> do
let [a,b,c,d,e] = srcInfoPoints l
printString "<"
exactPC xn
mapM_ exactPC attrs
maybeEP exactPC mat
printStringAt (pos b) ">"
mapM_ exactPC ps
printStringAt (pos c) "</"
printWhitespace (pos d)
exactP xn
printStringAt (pos e) ">"
PXETag l xn attrs mat -> do
let [a,b] = srcInfoPoints l
printString "<"
exactPC xn
mapM_ exactPC attrs
maybeEP exactPC mat
printStringAt (pos b) "/>"
PXPcdata l str -> printString str
PXPatTag l p   -> do
let [a,b] = srcInfoPoints l
printString "<%"
exactPC p
printString "%>"
PXRPats  l rps  -> bracketList ("<[",",","]>") (srcInfoPoints l) rps
PExplTypeArg l qn t -> do
let [a,b] = srcInfoPoints l
exactP qn
printStringAt (pos a) "{|"
exactPC t
printStringAt (pos b) "|}"
PQuasiQuote l name qt   -> printString \$ "[\$" ++ name ++ "|" ++ qt ++ "]"
PBangPat l p    -> printString "!" >> exactPC p

instance ExactP PatField where
exactP pf = case pf of
PFieldPat l qn p        -> do
let [a] = srcInfoPoints l
exactP qn
printStringAt (pos a) "="
exactPC p
PFieldPun l n   -> exactP n
PFieldWildcard l -> printString ".."

instance ExactP RPat where
exactP rpat = case rpat of
RPOp l rp op    -> exactP rp >> exactPC op
RPEither l r1 r2 -> do
let [a] = srcInfoPoints l
exactP r1
printStringAt (pos a) "|"
exactPC r2
RPSeq l rps -> bracketList ("(|",",","|)") (srcInfoPoints l) rps
RPGuard l p stmts   -> do
let (a:pts) = srcInfoPoints l
printString "(|"
exactPC p
bracketList ("|",",","|)") pts stmts
RPCAs l n rp    -> do
let [a] = srcInfoPoints l
exactP n
printStringAt (pos a) "@:"
exactPC rp
RPAs l n rp     -> do
let [a] = srcInfoPoints l
exactP n
printStringAt (pos a) "@"
exactPC rp
RPParen l rp    -> do
parenList (srcInfoPoints l) [rp]
RPPat l p   -> exactP p

instance ExactP RPatOp where
exactP rop = printString \$ case rop of
RPStar  l  -> "*"
RPStarG l  -> "*!"
RPPlus  l  -> "+"
RPPlusG l  -> "+!"
RPOpt   l  -> "?"
RPOptG  l  -> "?!"

instance ExactP PXAttr where
exactP (PXAttr l xn p) = do
let [a] = srcInfoPoints l
exactP xn
printStringAt (pos a) "="
exactPC p

instance ExactP XName where
exactP xn = case xn of
XName l name -> printString name
XDomName l dom name -> do
let [a,b,c] = srcInfoPoints l
printString dom
printStringAt (pos b) ":"
printStringAt (pos c) name

instance ExactP Binds where
exactP (BDecls  l ds)  = layoutList (srcInfoPoints l) (sepFunBinds ds)
exactP (IPBinds l ips) = layoutList (srcInfoPoints l) ips

instance ExactP CallConv where
exactP (StdCall _) = printString "stdcall"
exactP (CCall   _) = printString "ccall"

instance ExactP Safety where
exactP (PlayRisky _) = printString "unsafe"
exactP (PlaySafe _ b) = printString \$ if b then "threadsafe" else "safe"

instance ExactP Rule where
exactP (Rule l str mact mrvs e1 e2) = do
let (a:pts) = srcInfoPoints l
printString (show str)
maybeEP exactP mact
[x] <- case mrvs of
Nothing -> return pts
Just rvs -> do
let (a:b:pts') = pts
printStringAt (pos a) "forall"
mapM_ exactPC rvs
printStringAt (pos b) "."
return pts'
exactPC e1
printStringAt (pos x) "="
exactPC e2

instance ExactP RuleVar where
exactP (TypedRuleVar l n t) = do
let [a,b,c] = srcInfoPoints l
printString "("
exactPC n
printStringAt (pos b) "::"
exactPC t
printStringAt (pos c) ")"
exactP (RuleVar l n) = exactP n

instance ExactP Activation where
exactP (ActiveFrom   l i) =
printPoints l ["[", show i, "]"]
exactP (ActiveUntil  l i) =
printPoints l ["[", "~", show i, "]"]

instance ExactP FieldDecl where
exactP (FieldDecl l ns bt) = do
let pts = srcInfoPoints l
printInterleaved' (zip (init pts) (repeat ",") ++ [(last pts, "::")]) ns
exactPC bt

instance ExactP IPBind where
exactP (IPBind l ipn e) = do
let [a] = srcInfoPoints l
exactP ipn
printStringAt (pos a) "="
exactPC e
```