-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Exts.Annotated.ExactPrint
-- Copyright   :  (c) Niklas Broberg 2009
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
-- Stability   :  stable
-- Portability :  portable
--
-- Exact-printer for Haskell abstract syntax. The input is a (semi-concrete)
-- abstract syntax tree, annotated with exact source information to enable
-- printing the tree exactly as it was parsed.
--
-----------------------------------------------------------------------------
module Language.Haskell.Exts.Annotated.ExactPrint
        ( exactPrint
        , ExactP
        ) where

import Language.Haskell.Exts.Annotated.Syntax
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Comments

import Control.Monad (when)
import Control.Arrow ((***), (&&&))

-- import Debug.Trace (trace)

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

type Pos = (Int,Int)

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

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

instance Monad EP where
  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 ()
padUntil (l,c) = do
    (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 ()
mPrintComments p = do
    mc <- getComment
    case mc of
     Nothing -> return ()
     Just (Comment multi s str) ->
        when (pos s < p) $ do
            dropComment
            padUntil (pos s)
            printComment multi str
            setPos (srcSpanEndLine s, srcSpanEndColumn s)
            mPrintComments p

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

printWhitespace :: Pos -> EP ()
printWhitespace p = mPrintComments p >> padUntil p

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

errorEP :: String -> EP a
errorEP = fail

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

-- | Print an AST exactly as specified by the annotations on the nodes in the tree.
exactPrint :: (ExactP ast) => ast SrcSpanInfo -> [Comment] -> String
exactPrint ast cs = runEP (exactPC ast) cs

exactPC :: (ExactP ast) => ast SrcSpanInfo -> 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 loc => [(loc, String)] -> EP ()
printStrs = printSeq . map (pos *** printString)

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

printInterleaved, printInterleaved' :: (Annotated ast, ExactP ast, SrcInfo loc) => [(loc, String)] -> [ast SrcSpanInfo] -> EP ()
printInterleaved sistrs asts = printSeq $
    interleave (map (pos *** printString ) sistrs)
               (map (pos . ann &&& exactP) 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 SrcSpanInfo] -> 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 SrcSpanInfo] -> EP ()
parenList = bracketList ("(",",",")")
squareList = bracketList ("[",",","]")
curlyList = bracketList ("{",",","}")

layoutList :: (Functor ast, Show (ast ()), Annotated ast, ExactP ast) => [SrcSpan] -> [ast SrcSpanInfo] -> 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


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

class Annotated ast => ExactP ast where
  exactP :: ast SrcSpanInfo -> 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-1) "," ++ ["#)"]
         _       -> "(" : replicate (n-1) "," ++ [")"]
    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
        case srcInfoPoints (ann qn) of
         [a,b,c] -> do
            printString "("
            printWhitespace (pos b)
            epQName qn
            printStringAt (pos c) ")"
         _ -> errorEP "ExactP: QName is given wrong number of srcInfoPoints"
    | otherwise = epQName qn

epQName :: QName SrcSpanInfo -> 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 SrcSpanInfo -> EP ()
epInfixQName qn
    | isSymbol (getName qn) = printWhitespace (pos (ann qn)) >> epQName qn
    | otherwise = do
        case srcInfoPoints (ann qn) of
         [a,b,c] -> do
            printStringAt (pos a) "`"
            printWhitespace (pos b)
            epQName qn
            printStringAt (pos c) "`"
         _ -> errorEP "ExactP: QName (epInfixName) is given wrong number of srcInfoPoints"

instance ExactP Name where
  exactP n = case n of
    Ident  l str    -> printString str
    Symbol l str    -> do
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "("
            printWhitespace (pos b)
            printString str
            printStringAt (pos c) ")"
         _ -> errorEP "ExactP: Name is given wrong number of srcInfoPoints"

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

epInfixName :: Name SrcSpanInfo -> EP ()
epInfixName n
    | isSymbol n = printWhitespace (pos (ann n)) >> epName n
    | otherwise = do
        case srcInfoPoints (ann n) of
         [a,b,c] -> do
            printStringAt (pos a) "`"
            printWhitespace (pos b)
            epName n
            printStringAt (pos c) "`"
         _ -> errorEP "ExactP: Name (epInfixName) is given wrong number of srcInfoPoints"

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"
    case srcInfoPoints l of
     (a:pts) -> do
        pts <- if src then
                 case pts of
                  x:y:pts' -> do
                     printStringAt (pos x) "{-# SOURCE"
                     printStringAt (pos y) "#-}"
                     return pts'
                  _ -> errorEP "ExactP: ImportDecl is given too few srcInfoPoints"
                else return pts
        pts <- if qf then
                 case pts of
                  x:pts' -> do
                     printStringAt (pos x) "qualified"
                     return pts'
                  _ -> errorEP "ExactP: ImportDecl is given too few srcInfoPoints"
                else return pts
        pts <- case mpkg of
                Just pkg ->
                  case pts of
                   x:pts' -> do
                      printStringAt (pos x) $ show pkg
                      return pts'
                   _ -> errorEP "ExactP: ImportDecl is given too few srcInfoPoints"
                _ -> return pts
        exactPC mn
        pts <- case mas of
                Just as ->
                 case pts of
                  x:pts' -> do
                     printStringAt (pos x) "as"
                     exactPC as
                     return pts'
                  _ -> errorEP "ExactP: ImportDecl is given too few srcInfoPoints"
                _ -> return pts
        case mispecs of
         Nothing -> return ()
         Just ispecs -> exactPC ispecs
     _ -> errorEP "ExactP: ImportDecl is given too few srcInfoPoints"

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 (pos *** printString) $ lList pts)
                     (map (pos . ann &&& exactPC) ids ++ map (pos . ann &&& exactPC) (sepFunBinds decls))
    XmlPage l _mn oss xn attrs mat es  -> do
        let (oPts, pPts) = splitAt (max (length oss + 1) 2) $ srcInfoPoints l
        case pPts of
         [a,b,c,d,e] -> do
            layoutList oPts oss
            printStringAt (pos a) "<"
            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) ">"
         _ -> errorEP "ExactP: Module: XmlPage is given wrong number of srcInfoPoints"
    XmlHybrid l mmh oss ids decls xn attrs mat es -> do
        let (oPts, pts) = splitAt (max (length oss + 1) 2) (srcInfoPoints l)
        layoutList oPts oss
        maybeEP exactPC mmh
        let (dPts, pPts) = splitAt (length pts - 5) pts
        case pPts of
         [a,b,c,d,e] -> do
            printStreams (map (\(p,s) -> (pos p, printString s)) $ lList dPts)
                         (map (\i -> (pos $ ann i, exactPC i)) ids ++ map (\d -> (pos $ ann d, exactPC d)) (sepFunBinds decls))
    
            printStringAt (pos a) "<"
            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) ">"
         _ -> errorEP "ExactP: Module: XmlHybrid is given wrong number of srcInfoPoints"

instance ExactP ModuleHead where
  exactP (ModuleHead l mn mwt mess) = do
    case srcInfoPoints l of
     [a,b] -> do
        printStringAt (pos a) "module"
        exactPC mn
        maybeEP exactPC mwt
        maybeEP exactPC mess
        printStringAt (pos b) "where"
     _ -> errorEP "ExactP: ModuleHead is given wrong number of srcInfoPoints"

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      ->
        case srcInfoPoints l of
         [a,b] -> do
            printStringAt (pos a) "type"
            exactPC dh
            printStringAt (pos b) "="
            exactPC t
         _ -> errorEP "ExactP: Decl: TypeDecl is given wrong number of srcInfoPoints"
    TypeFamDecl  l dh mk     ->
        case srcInfoPoints l of
         a:b:ps -> do
            printStringAt (pos a) "type"
            printStringAt (pos b) "family"
            exactPC dh
            maybeEP (\k -> printStringAt (pos (head ps)) "::" >> exactPC k) mk
         _ -> errorEP "ExactP: Decl: TypeFamDecl is given wrong number of srcInfoPoints"
    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
        pts <- case mk of
                Nothing -> return pts
                Just kd -> case pts of 
                            p:pts' -> do
                               printStringAt (pos p) "::"
                               exactPC kd
                               return pts'
                            _ -> errorEP "ExactP: Decl: GDataDecl is given too few srcInfoPoints"
        case pts of
         x:pts -> do
            printStringAt (pos x) "where"
            layoutList pts gds
            maybeEP exactPC mder
         _ -> errorEP "ExactP: Decl: GDataDecl is given too few srcInfoPoints"
    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 ->
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "type"
            printStringAt (pos b) "instance"
            exactPC t1
            printStringAt (pos c) "="
            exactPC t2
         _ -> errorEP "ExactP: Decl: TypeInsDecl is given wrong number of srcInfoPoints"
    DataInsDecl  l dn t constrs mder    ->
        case srcInfoPoints l of
         p:pts -> do
            exactP dn
            printStringAt (pos p) "instance"
            exactPC t
            printInterleaved (zip pts ("=": repeat "|")) constrs
            maybeEP exactPC mder
         _ -> errorEP "ExactP: Decl: DataInsDecl is given too few srcInfoPoints"
    GDataInsDecl l dn t mk gds mder     ->
        case srcInfoPoints l of
         p:pts -> do
            exactP dn
            printStringAt (pos p) "instance"
            exactPC t
            pts <- case mk of
                    Nothing -> return pts
                    Just kd -> case pts of
                                p:pts' -> do
                                    printStringAt (pos p) "::"
                                    exactPC kd
                                    return pts'
                                _ -> errorEP "ExactP: Decl: GDataInsDecl is given too few srcInfoPoints"
            case pts of
             x:pts -> do
                printStringAt (pos x) "where"
                layoutList pts gds
                maybeEP exactPC mder
             _ -> errorEP "ExactP: Decl: GDataInsDecl is given too few srcInfoPoints" 
         _ -> errorEP "ExactP: Decl: GDataInsDecl is given too few srcInfoPoints"
    ClassDecl    l mctxt dh fds mcds    ->
        case srcInfoPoints l of
         a:pts -> do
            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 ->
                case pts of
                 p:pts' -> do
                    printStringAt (pos p) "where"
                    layoutList pts' $ sepClassFunBinds cds
                 _ -> errorEP "ExactP: Decl: ClassDecl is given too few srcInfoPoints"
                ) mcds                
         _ -> errorEP "ExactP: Decl: ClassDecl is given too few srcInfoPoints"
    InstDecl     l mctxt ih mids        ->
        case srcInfoPoints l of
         a:pts -> do
            printString "instance"
            maybeEP exactPC mctxt
            exactPC ih
            maybeEP (\ids -> do
                let (p:pts') = pts
                printStringAt (pos p) "where"
                layoutList pts' $ sepInstFunBinds ids
                ) mids
         _ -> errorEP "ExactP: Decl: InstDecl is given too few srcInfoPoints"
    DerivDecl    l mctxt ih             ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "deriving"
            printStringAt (pos b) "instance"
            maybeEP exactPC mctxt
            exactPC ih
         _ -> errorEP "ExactP: Decl: DerivDecl is given wrong number of srcInfoPoints"
    InfixDecl    l assoc mprec ops      -> do
        let pts = srcInfoPoints l
        exactP assoc
        pts <- case mprec of
                Nothing -> return pts
                Just prec ->
                    case pts of
                     p:pts' -> do
                        printStringAt (pos p) (show prec)
                        return pts'
                     _ -> errorEP "ExactP: Decl: InfixDecl is given too few srcInfoPoints"
        printInterleaved' (zip pts (repeat ",")) ops
    DefaultDecl  l ts   ->
        case srcInfoPoints l of
         a:pts -> do
            printString "default"
            printInterleaved (zip (init pts) ("(":repeat ",")) ts
            printStringAt (pos (last pts)) ")"
         _ -> errorEP "ExactP: Decl: DefaultDecl is given too few srcInfoPoints"
    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  -> case pts of
                            x:pts'-> do
                                printStringAt (pos x) "::"
                                exactPC t
                                return pts'
                            _ -> errorEP "ExactP: Decl: PatBind is given too few srcInfoPoints"
        exactPC rhs
        maybeEP (\bs -> printStringAt (pos (head pts)) "where" >> exactPC bs) mbs
    ForImp       l cc msf mstr n t   ->
        case srcInfoPoints l of
         a:b:pts -> do
            printString "foreign"
            printStringAt (pos b) "import"
            exactPC cc
            maybeEP exactPC msf
            pts <- case mstr of
                      Nothing -> return pts
                      Just str -> case pts of 
                                   x:pts' -> do
                                      printStringAt (pos x) (show str)
                                      return pts'
                                   _ -> errorEP "ExactP: Decl: ForImp is given too few srcInfoPoints"
            case pts of
             y:_ -> do
                exactPC n
                printStringAt (pos y) "::"
                exactPC t
             _ -> errorEP "ExactP: Decl: ForImp is given too few srcInfoPoints"
         _ -> errorEP "ExactP: Decl: ForImp is given too few srcInfoPoints"
    ForExp       l cc mstr n t      ->
        case srcInfoPoints l of
         a:b:pts -> do
            printString "foreign"
            printStringAt (pos b) "export"
            exactPC cc
            pts <- case mstr of
                      Nothing -> return pts
                      Just str -> case pts of
                                   x:pts' -> do
                                      printStringAt (pos x) (show str)
                                      return pts'
                                   _ -> errorEP "ExactP: Decl: ForExp is given too few srcInfoPoints"
            case pts of
             y:_ -> do
                exactPC n
                printStringAt (pos y) "::"
                exactPC t
             _ -> errorEP "ExactP: Decl: ForExp is given too few srcInfoPoints"
         _ -> errorEP "ExactP: Decl: ForExp is given too few srcInfoPoints"
    RulePragmaDecl   l rs   ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "{-# RULES"
            mapM_ exactPC rs
            printStringAt (pos b) "#-}"
         _ -> errorEP "ExactP: Decl: RulePragmaDecl is given too few srcInfoPoints"
    DeprPragmaDecl   l nstrs ->
        case srcInfoPoints l of
         a:pts -> do
            printString "{-# DEPRECATED"
            printWarndeprs (map pos (init pts)) nstrs
            printStringAt (pos (last pts)) "#-}"
         _ -> errorEP "ExactP: Decl: DeprPragmaDecl is given too few srcInfoPoints"
    WarnPragmaDecl   l nstrs ->
        case srcInfoPoints l of
         a:pts -> do
            printString "{-# WARNING"
            printWarndeprs (map pos (init pts)) nstrs
            printStringAt (pos (last pts)) "#-}"
         _ -> errorEP "ExactP: Decl: WarnPragmaDecl is given too few srcInfoPoints"
    InlineSig        l inl mact qn    ->
        case srcInfoPoints l of
         [a,b] -> do
            printString $ if inl then "{-# INLINE" else "{-# NOINLINE"
            maybeEP exactPC mact
            exactPC qn
            printStringAt (pos b) "#-}"
         _ -> errorEP "ExactP: Decl: InlineSig is given wrong number of srcInfoPoints"
    SpecSig          l qn ts        ->
        case srcInfoPoints l of
         a:pts -> do
            printString "{-# SPECIALISE"
            exactPC qn
            printInterleaved (zip pts ("::" : repeat "," ++ ["#-}"])) ts
         _ -> errorEP "ExactP: Decl: SpecSig is given too few srcInfoPoints"
    SpecInlineSig    l b mact qn ts ->
        case srcInfoPoints l of
         a:pts -> do
            printString $ "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE"
            maybeEP exactPC mact
            exactPC qn
            printInterleaved (zip pts ("::" : repeat "," ++ ["#-}"])) ts
         _ -> errorEP "ExactP: Decl: SpecInlineSig is given too few srcInfoPoints"
    InstSig          l mctxt ih     ->
        case srcInfoPoints l of
         [a,b,c] -> do
            printString $ "{-# SPECIALISE"
            printStringAt (pos b) "instance"
            maybeEP exactPC mctxt
            exactPC ih
            printStringAt (pos c) "#-}"
         _ -> errorEP "ExactP: Decl: InstSig is given too few srcInfoPoints"

printWarndeprs :: [Pos] -> [([Name SrcSpanInfo], String)] -> EP ()
printWarndeprs _ [] = return ()
printWarndeprs ps ((ns,str):nsts) = printWd ps ns str nsts
  where printWd :: [Pos] -> [Name SrcSpanInfo] -> String -> [([Name SrcSpanInfo], 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 SrcSpanInfo] -> [Decl SrcSpanInfo]
sepFunBinds [] = []
sepFunBinds (FunBind _ ms:ds) = map (\m -> FunBind (ann m) [m]) ms ++ sepFunBinds ds
sepFunBinds (d:ds) = d : sepFunBinds ds

sepClassFunBinds :: [ClassDecl SrcSpanInfo] -> [ClassDecl SrcSpanInfo]
sepClassFunBinds [] = []
sepClassFunBinds (ClsDecl _ (FunBind _ ms):ds) = map (\m -> ClsDecl (ann m) $ FunBind (ann m) [m]) ms ++ sepClassFunBinds ds
sepClassFunBinds (d:ds) = d : sepClassFunBinds ds

sepInstFunBinds :: [InstDecl SrcSpanInfo] -> [InstDecl SrcSpanInfo]
sepInstFunBinds [] = []
sepInstFunBinds (InsDecl _ (FunBind _ ms):ds) = map (\m -> InsDecl (ann m) $ FunBind (ann m) [m]) ms ++ sepInstFunBinds ds
sepInstFunBinds (d:ds) = d : sepInstFunBinds ds

instance ExactP DeclHead where
  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        ->
        case srcInfoPoints l of
         [_,b] -> printString "(" >> exactPC dh >> printStringAt (pos b) ")"
         _ -> errorEP "ExactP: DeclHead: DeclParen is given wrong number of srcInfoPoints"

instance ExactP InstHead where
  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        ->
        case srcInfoPoints l of
         [_,b] -> printString "(" >> exactPC ih >> printStringAt (pos b) ")"
         _ -> errorEP "ExactP: InstHead: IHParen is given wrong number of srcInfoPoints"

instance ExactP TyVarBind where
  exactP (KindedVar   l n k) =
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "("
            exactPC n
            printStringAt (pos b) "::"
            exactPC k
            printStringAt (pos c) ")"
         _ -> errorEP "ExactP: TyVarBind: KindedVar is given wrong number of srcInfoPoints"
  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 ->
        case srcInfoPoints l of
         [a] -> do
            exactP k1
            printStringAt (pos a) "->"
            exactPC k2
         _ -> errorEP "ExactP: Kind: KindFn is given wrong number of srcInfoPoints"
    KindParen l kd  -> do
        case srcInfoPoints l of
         [a,b] -> do
            printString "("
            exactPC kd
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Kind: KindParen is given wrong number of srcInfoPoints"
    KindVar l n     -> exactP n       

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 ->
                    case pts of
                     a:b:pts' -> do
                        printString "forall"
                        mapM_ exactPC tvs
                        printStringAt (pos b) "."
                        return pts'
                     _ -> errorEP "ExactP: Type: TyForall is given too few srcInfoPoints"
        maybeEP exactPC mctxt
        exactPC t
    TyFun   l t1 t2 -> do
        case srcInfoPoints l of
         [a] -> do
            exactP t1
            printStringAt (pos a) "->"
            exactPC t2
         _ -> errorEP "ExactP: Type: TyFun is given wrong number of srcInfoPoints"
    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
        case srcInfoPoints l of
         [a,b] -> do
            printString "["
            exactPC t
            printStringAt (pos b) "]"
         _ -> errorEP "ExactP: Type: TyList is given wrong number of srcInfoPoints"
    TyApp   l t1 t2 -> exactP t1 >> exactPC t2
    TyVar   l n     -> exactP n
    TyCon   l qn    -> exactP qn
    TyParen l t     -> do
        case srcInfoPoints l of
         [a,b] -> do
            printString "("
            exactPC t
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Type: TyParen is given wrong number of srcInfoPoints"
    TyInfix l t1 qn t2 -> exactP t1 >> epInfixQName qn >> exactPC t2
    TyKind  l t kd -> do
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "("
            exactPC t
            printStringAt (pos b) "::"
            exactPC kd
            printStringAt (pos c) ")"
         _ -> errorEP "ExactP: Type: TyKind is given wrong number of srcInfoPoints"

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 ->
        case pts of
         [a,b] -> do
            printStringAt (pos a) "("
            printContext ctxt
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Context: CxParen is given wrong number of srcInfoPoints"
     CxSingle l asst -> exactP asst
     CxEmpty l ->
        case pts of
         [a,b] -> do
            printStringAt (pos a) "("
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Context: CxEmpty is given wrong number of srcInfoPoints"
     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    ->
        case srcInfoPoints l of
         [a] -> do
            exactP ipn
            printStringAt (pos a) "::"
            exactPC t
         _ -> errorEP "ExactP: Asst: IParam is given wrong number of srcInfoPoints"
    EqualP l t1 t2  ->
        case srcInfoPoints l of
         [a] -> do
            exactP t1
            printStringAt (pos a) "~"
            exactPC t2

instance ExactP Deriving where
  exactP (Deriving l ihs) =
    case srcInfoPoints l of
     x:pts -> do
        printString "deriving"
        case pts of
         [] -> exactPC $ head ihs
         _  -> parenList pts ihs
     _ -> errorEP "ExactP: Deriving is given too few srcInfoPoints"

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

instance ExactP InstDecl where
  exactP idecl = case idecl of
    InsDecl   l d -> exactP d
    InsType   l t1 t2 ->
        case srcInfoPoints l of
         [a,b] -> do
            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
        pts <- case mk of
                Nothing -> return pts
                Just kd -> case pts of
                            p:pts' -> do
                                printStringAt (pos p) "::"
                                exactPC kd
                                return pts'
                            _ -> errorEP "ExactP: InstDecl: InsGData is given too few srcInfoPoints"
        case pts of
         x:_ -> do
            printStringAt (pos x) "where"
            mapM_ exactPC gds
            maybeEP exactPC mder
         _ -> errorEP "ExactP: InstDecl: InsGData is given too few srcInfoPoints"
    InsInline l inl mact qn   -> do
        case srcInfoPoints l of
         [a,b] -> do
            printString $ if inl then "{-# INLINE" else "{-# NOINLINE"
            maybeEP exactPC mact
            exactPC qn
            printStringAt (pos b) "#-}"
         _ -> errorEP "ExactP: InstDecl: InsInline is given wrong number of srcInfoPoints"

instance ExactP FunDep where
  exactP (FunDep l nxs nys) =
    case srcInfoPoints l of
     [a] -> do
        mapM_ exactPC nxs
        printStringAt (pos a) "->"
        mapM_ exactPC nys
     _ -> errorEP "ExactP: FunDep is given wrong number of srcInfoPoints"

instance ExactP QualConDecl where
  exactP (QualConDecl l mtvs mctxt cd) = do
        let pts = srcInfoPoints l
        pts <- case mtvs of
                Nothing -> return pts
                Just tvs ->
                    case pts of
                     a:b:pts' -> do
                        printString "forall"
                        mapM_ exactPC tvs
                        printStringAt (pos b) "."
                        return pts'
                     _ -> errorEP "ExactP: QualConDecl is given wrong number of srcInfoPoints"
        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

instance ExactP GadtDecl where
  exactP (GadtDecl l n t) =
    case srcInfoPoints l of
     [a] -> do
        exactP n
        printStringAt (pos a) "::"
        exactPC t
     _ -> errorEP "ExactP: GadtDecl is given wrong number of srcInfoPoints"

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

instance ExactP Splice where
  exactP (IdSplice l str) = printString $ '$':str
  exactP (ParenSplice l e) =
    case srcInfoPoints l of
     [a,b] -> do
        printString "$("
        exactPC e
        printStringAt (pos b) ")"
     _ -> errorEP "ExactP: Splice: ParenSplice is given wrong number of srcInfoPoints"

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   ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "\\"
            mapM_ exactPC ps
            printStringAt (pos b) "->"
            exactPC e
         _ -> errorEP "ExactP: Exp: Lambda is given wrong number of srcInfoPoints"
    Let l bs e      ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "let"
            exactPC bs
            printStringAt (pos b) "in"
            exactPC e
         _ -> errorEP "ExactP: Exp: Let is given wrong number of srcInfoPoints"
    If l ec et ee   ->
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "if"
            exactPC ec
            printStringAt (pos b) "then"
            exactPC et
            printStringAt (pos c) "else"
            exactPC ee
         _ -> errorEP "ExactP: Exp: If is given wrong number of srcInfoPoints"
    Case l e alts   ->
        case srcInfoPoints l of
         a:b:pts -> do
            printString "case"
            exactPC e
            printStringAt (pos b) "of"
            layoutList pts alts
         _ -> errorEP "ExactP: Exp: Case is given too few srcInfoPoints"
    Do l stmts      ->
        case srcInfoPoints l of
         a:pts -> do
            printString "do"
            layoutList pts stmts
         _ -> errorEP "ExactP: Exp: Do is given too few srcInfoPoints"
    MDo l stmts     ->
        case srcInfoPoints l of
         a:pts -> do
            printString "mdo"
            layoutList pts stmts
         _ -> errorEP "ExactP: Exp: Mdo is given wrong number of srcInfoPoints"
    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 (maybe (0,0) (pos . ann) &&& maybeEP exactPC) mexps)
    List l es               -> squareList (srcInfoPoints l) es
    Paren l p               -> parenList (srcInfoPoints l) [p]
    LeftSection l e qop     ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "("
            exactPC e
            exactPC qop
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Exp: LeftSection is given wrong number of srcInfoPoints"
    RightSection l qop e    ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "("
            exactPC qop
            exactPC e
            printStringAt (pos b) ")"
         _ -> errorEP "ExactP: Exp: RightSection is given wrong number of srcInfoPoints"
    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            ->
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "["
            exactPC e
            printStringAt (pos b) ".."
            printStringAt (pos c) "]"
         _ -> errorEP "ExactP: Exp: EnumFrom is given wrong number of srcInfoPoints"
    EnumFromTo l e1 e2      ->
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "["
            exactPC e1
            printStringAt (pos b) ".."
            exactPC e2
            printStringAt (pos c) "]"
         _ -> errorEP "ExactP: Exp: EnumFromTo is given wrong number of srcInfoPoints"
    EnumFromThen l e1 e2    ->
        case srcInfoPoints l of
         [a,b,c,d] -> do
            printString "["
            exactPC e1
            printStringAt (pos b) ","
            exactPC e2
            printStringAt (pos c) ".."
            printStringAt (pos d) "]"
         _ -> errorEP "ExactP: Exp: EnumFromThen is given wrong number of srcInfoPoints"
    EnumFromThenTo l e1 e2 e3   ->
        case srcInfoPoints l of
         [a,b,c,d] -> do
            printString "["
            exactPC e1
            printStringAt (pos b) ","
            exactPC e2
            printStringAt (pos c) ".."
            exactPC e3
            printStringAt (pos d) "]"
         _ -> errorEP "ExactP: Exp: EnumFromToThen is given wrong number of srcInfoPoints"
    ListComp l e qss            ->
        case srcInfoPoints l of
         a:pts -> do
            printString "["
            exactPC e
            bracketList ("|",",","]") pts qss
         _ -> errorEP "ExactP: Exp: ListComp is given too few srcInfoPoints"
    ParComp  l e qsss           ->
        case srcInfoPoints l of
         a:pts -> do
            let (strs, qss) = unzip $ pairUp qsss
            printString "["
            exactPC e
            printInterleaved (zip pts (strs ++ ["]"])) qss
         _ -> errorEP "ExactP: Exp: ParComp is given wrong number of srcInfoPoints"
      where pairUp [] = []
            pairUp ((a:as):xs) = ("|", a) : zip (repeat ",") as ++ pairUp xs

    ExpTypeSig l e t    ->
        case srcInfoPoints l of
         [a] -> do
            exactP e
            printStringAt (pos a) "::"
            exactPC t
         _ -> errorEP "ExactP: Exp: ExpTypeSig is given wrong number of srcInfoPoints"
    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  ->
        case srcInfoPoints l of
         [a,b,c,d,e] -> do
            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) ">"
         _ -> errorEP "ExactP: Exp: XTag is given wrong number of srcInfoPoints"
    XETag l xn attrs mat    ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "<"
            exactPC xn
            mapM_ exactPC attrs
            maybeEP exactPC mat
            printStringAt (pos b) "/>"
         _ -> errorEP "ExactP: Exp: XETag is given wrong number of srcInfoPoints"
    XPcdata l str   -> printString str
    XExpTag l e     ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "<%"
            exactPC e
            printString "%>"
         _ -> errorEP "ExactP: Exp: XExpTag is given wrong number of srcInfoPoints"

    CorePragma l      str e         ->
        case srcInfoPoints l of
         [a,b] -> do
            printString $ "{-# CORE " ++ show str
            printStringAt (pos b) "#-}"
            exactPC e
         _ -> errorEP "ExactP: Exp: CorePragma is given wrong number of srcInfoPoints"
    SCCPragma  l      str e         ->
        case srcInfoPoints l of
         [a,b] -> do
            printString $ "{-# SCC " ++ show str
            printStringAt (pos b) "#-}"
            exactPC e
         _ -> errorEP "ExactP: Exp: SCCPragma is given wrong number of srcInfoPoints"
    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   ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "proc"
            exactPC p
            printStringAt (pos b) "->"
            exactPC e
         _ -> errorEP "ExactP: Exp: Proc is given wrong number of srcInfoPoints"
    LeftArrApp      l e1 e2 ->
        case srcInfoPoints l of
         [a] -> do
            exactP e1
            printStringAt (pos a) "-<"
            exactPC e2
         _ -> errorEP "ExactP: Exp: LeftArrApp is given wrong number of srcInfoPoints"
    RightArrApp     l e1 e2 -> do
        case srcInfoPoints l of
         [a] -> do
            exactP e1
            printStringAt (pos a) ">-"
            exactPC e2
         _ -> errorEP "ExactP: Exp: RightArrApp is given wrong number of srcInfoPoints"
    LeftArrHighApp  l e1 e2 -> do
        case srcInfoPoints l of
         [a] -> do
            exactP e1
            printStringAt (pos a) "-<<"
            exactPC e2
         _ -> errorEP "ExactP: Exp: LeftArrHighApp is given wrong number of srcInfoPoints"
    RightArrHighApp l e1 e2 -> do
        case srcInfoPoints l of
         [a] -> do
            exactP e1
            printStringAt (pos a) ">>-"
            exactPC e2
         _ -> errorEP "ExactP: Exp: RightArrHighApp is given wrong number of srcInfoPoints"

instance ExactP FieldUpdate where
  exactP fup = case fup of
    FieldUpdate l qn e  -> do
      case srcInfoPoints l of
       [a] -> do
          exactP qn
          printStringAt (pos a) "="
          exactPC e
       _ -> errorEP "ExactP: FieldUpdate is given wrong number of srcInfoPoints"
    FieldPun l n    -> exactP n
    FieldWildcard l -> printString ".."

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

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
        case srcInfoPoints l of
         [a,b] -> do
            printString "then"
            exactPC e1
            printStringAt (pos b) "by"
            exactPC e2
         _ -> errorEP "ExactP: QualStmt: ThenBy is given wrong number of srcInfoPoints"
    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  ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "[|"
            exactPC e
            printStringAt (pos b) "|]"
         _ -> errorEP "ExactP: Bracket: ExpBracket is given wrong number of srcInfoPoints"
    PatBracket l p  ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "[p|"
            exactPC p
            printStringAt (pos b) "|]"
         _ -> errorEP "ExactP: Bracket: PatBracket is given wrong number of srcInfoPoints"
    TypeBracket l t  -> do
        case srcInfoPoints l of
         [a,b] -> do
            printString "[t|"
            exactPC t
            printStringAt (pos b) "|]"
         _ -> errorEP "ExactP: Bracket: TypeBracket is given wrong number of srcInfoPoints"
    DeclBracket l ds ->
        case srcInfoPoints l of
         a:pts -> do
            printString "[d|"
            layoutList (init pts) (sepFunBinds ds)
            printStringAt (pos (last pts)) "|]"
         _ -> errorEP "ExactP: Bracket: DeclBracket is given too few srcInfoPoints"

instance ExactP XAttr where
  exactP (XAttr l xn e) =
    case srcInfoPoints l of
     [a] -> do
        exactP xn
        printStringAt (pos a) "="
        exactPC e
     _ -> errorEP "ExactP: XAttr is given wrong number of srcInfoPoints"

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
        len = length pts
        pars = len `div` 2
        (oPars,cParsWh) = splitAt pars pts
        (cPars,whPt) = splitAt pars cParsWh    -- whPt is either singleton or empty
    printStrs (zip oPars (repeat "("))
    exactPC n
    printStreams (zip (map pos cPars) (repeat $ printString ")")) (map (pos . ann &&& exactPC) ps) 
    exactPC rhs
    maybeEP (\bds -> printStringAt (pos (head pts)) "where" >> exactPC bds) mbinds
  exactP (InfixMatch l a n bs rhs mbinds) = do
    let pts = srcInfoPoints l
        len = length pts
        pars = len `div` 2
        (oPars,cParsWh) = splitAt pars pts
        (cPars,whPt) = splitAt pars cParsWh    -- whPt is either singleton or empty
    printStrs (zip oPars (repeat "("))
    exactPC a
    epInfixName n
    printInterleaved' (zip cPars (repeat ")")) bs
    exactPC rhs
    maybeEP (\bds -> printStringAt (pos (head whPt)) "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) =
    case srcInfoPoints l of
     a:pts -> do
        printString "|"
        printInterleaved' (zip (init pts) (repeat ",") ++ [(last pts, "=")]) ss
        exactPC e
     _ -> errorEP "ExactP: GuardedRhs is given wrong number of srcInfoPoints"

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   ->
        case srcInfoPoints l of
         [a,b] -> do
            exactP n
            printStringAt (pos a) "+"
            printStringAt (pos b) (show k)
         _ -> errorEP "ExactP: Pat: PNPlusK is given wrong number of srcInfoPoints"
    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    ->
        case srcInfoPoints l of
         [a] -> do
            exactP n
            printStringAt (pos a) "@"
            exactPC p
         _ -> errorEP "ExactP: Pat: PAsPat is given wrong number of srcInfoPoints"
    PWildCard l -> printString "_"
    PIrrPat l p -> printString "~" >> exactPC p
    PatTypeSig l p t ->
        case srcInfoPoints l of
         [a] -> do
            exactP p
            printStringAt (pos a) "::"
            exactPC t
         _ -> errorEP "ExactP: Pat: PatTypeSig is given wrong number of srcInfoPoints"
    PViewPat l e p ->
        case srcInfoPoints l of
         [a] -> do
            exactP e
            printStringAt (pos a) "->"
            exactPC p
         _ -> errorEP "ExactP: Pat: PViewPat is given wrong number of srcInfoPoints"
    PRPat l rps -> squareList (srcInfoPoints l) rps
    PXTag l xn attrs mat ps ->
        case srcInfoPoints l of
         [a,b,c,d,e] -> do
            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) ">"
         _ -> errorEP "ExactP: Pat: PXTag is given wrong number of srcInfoPoints"
    PXETag l xn attrs mat ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "<"
            exactPC xn
            mapM_ exactPC attrs
            maybeEP exactPC mat
            printStringAt (pos b) "/>"
         _ -> errorEP "ExactP: Pat: PXETag is given wrong number of srcInfoPoints"
    PXPcdata l str -> printString str
    PXPatTag l p   ->
        case srcInfoPoints l of
         [a,b] -> do
            printString "<%"
            exactPC p
            printString "%>"
         _ -> errorEP "ExactP: Pat: PXPatTag is given wrong number of srcInfoPoints"
    PXRPats  l rps  -> bracketList ("<[",",","]>") (srcInfoPoints l) rps
    PExplTypeArg l qn t ->
        case srcInfoPoints l of
         [a,b] -> do
            exactP qn
            printStringAt (pos a) "{|"
            exactPC t
            printStringAt (pos b) "|}"
         _ -> errorEP "ExactP: Pat: PExplTypeArg is given wrong number of srcInfoPoints"
    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        ->
        case srcInfoPoints l of
         [a] -> do
            exactP qn
            printStringAt (pos a) "="
            exactPC p
         _ -> errorEP "ExactP: PatField: PFieldPat is given wrong number of srcInfoPoints"
    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 ->
      case srcInfoPoints l of
       [a] -> do
          exactP r1
          printStringAt (pos a) "|"
          exactPC r2
       _ -> errorEP "ExactP: RPat: RPEither is given wrong number of srcInfoPoints"
    RPSeq l rps -> bracketList ("(|",",","|)") (srcInfoPoints l) rps
    RPGuard l p stmts   ->
      case srcInfoPoints l of
       a:pts -> do
          printString "(|"
          exactPC p
          bracketList ("|",",","|)") pts stmts
       _ -> errorEP "ExactP: RPat: RPGuard is given wrong number of srcInfoPoints"
    RPCAs l n rp    ->
      case srcInfoPoints l of
       [a] -> do
          exactP n
          printStringAt (pos a) "@:"
          exactPC rp
       _ -> errorEP "ExactP: RPat: RPCAs is given wrong number of srcInfoPoints"
    RPAs l n rp     ->
      case srcInfoPoints l of
       [a] -> do
          exactP n
          printStringAt (pos a) "@"
          exactPC rp
       _ -> errorEP "ExactP: RPat: RPAs is given wrong number of srcInfoPoints"
    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) =
    case srcInfoPoints l of
     [a] -> do
        exactP xn
        printStringAt (pos a) "="
        exactPC p
     _ -> errorEP "ExactP: PXAttr is given wrong number of srcInfoPoints"

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

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) =
    case srcInfoPoints l of
     a:pts -> do
        printString (show str)
        maybeEP exactP mact
        pts <- case mrvs of
                Nothing -> return pts
                Just rvs ->
                    case pts of
                     a:b:pts' -> do
                        printStringAt (pos a) "forall"
                        mapM_ exactPC rvs
                        printStringAt (pos b) "."
                        return pts'
                     _ -> errorEP "ExactP: Rule is given too few srcInfoPoints"
        case pts of
         [x] -> do
            exactPC e1
            printStringAt (pos x) "="
            exactPC e2
         _ -> errorEP "ExactP: Rule is given wrong number of srcInfoPoints"
     _ -> errorEP "ExactP: Rule is given too few srcInfoPoints"

instance ExactP RuleVar where
  exactP (TypedRuleVar l n t) = do
        case srcInfoPoints l of
         [a,b,c] -> do
            printString "("
            exactPC n
            printStringAt (pos b) "::"
            exactPC t
            printStringAt (pos c) ")"
         _ -> errorEP "ExactP: RuleVar: TypedRuleVar is given wrong number of srcInfoPoints"
  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
    case srcInfoPoints l of
     [a] -> do
        exactP ipn
        printStringAt (pos a) "="
        exactPC e
     _ -> errorEP "ExactP: IPBind is given wrong number of srcInfoPoints"