{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.GHC.ExactPrint
--
-- Based on Language.Haskell.Exts.Annotated.ExactPrint
--
-----------------------------------------------------------------------------
module Language.Haskell.GHC.ExactPrint
        ( annotateAST
        , Anns
        , exactPrintAnnotated
        , exactPrintAnnotation

        , exactPrint
        , ExactP

        ) where

import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils

import Control.Applicative
import Control.Exception
import Control.Monad.RWS
import Data.Data
import Data.List
import Data.Maybe

import qualified Bag           as GHC
import qualified BasicTypes    as GHC
import qualified Class         as GHC
import qualified CoAxiom       as GHC
import qualified FastString    as GHC
import qualified ForeignCall   as GHC
import qualified GHC           as GHC
import qualified SrcLoc        as GHC

import qualified Data.Map as Map

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

-- Compatibiity types, from HSE

-- | A portion of the source, extended with information on the position of entities within the span.
data SrcSpanInfo = SrcSpanInfo
    { srcInfoSpan    :: GHC.SrcSpan
    , srcInfoPoints  :: [GHC.SrcSpan]    -- Marks the location of specific entities inside the span
    }
  deriving (Eq,Ord,Show,Typeable,Data)


-- | A class to work over all kinds of source location information.
class SrcInfo si where
  toSrcInfo   :: GHC.SrcLoc -> [GHC.SrcSpan] -> GHC.SrcLoc -> si
  fromSrcInfo :: SrcSpanInfo -> si
  getPointLoc :: si -> GHC.SrcLoc
  fileName    :: si -> String
  startLine   :: si -> Int
  startColumn :: si -> Int

  getPointLoc si = GHC.mkSrcLoc (GHC.mkFastString $ fileName si) (startLine si) (startColumn si)


instance SrcInfo GHC.SrcSpan where
  toSrcInfo   = error "toSrcInfo GHC.SrcSpan undefined"
  fromSrcInfo = error "toSrcInfo GHC.SrcSpan undefined"

  getPointLoc = GHC.srcSpanStart

  fileName (GHC.RealSrcSpan s) = GHC.unpackFS $ GHC.srcSpanFile s
  fileName _                   = "bad file name for SrcSpan"

  startLine   = srcSpanStartLine
  startColumn = srcSpanStartColumn

class Annotated a where
  ann :: a -> GHC.SrcSpan

instance Annotated (GHC.Located a) where
  ann (GHC.L l _) = l

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

-- The (ColOffset,ColOffset) value carries the normal and current
-- column offset. The second one captures the difference between the
-- original col when the DP was captured and the current one.

data EPState = EPState
             { epPos       :: Pos -- ^ Current output position
             , epAnns      :: Anns
             , epAnnKds    :: [[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local state with suitable refactoring?
                                                        -- AZ, it is already in the last element of Annotation, for withOffset
             }

data EPLocal = EPLocal
             { eFunId      :: (Bool, String)
             , eFunIsInfix :: Bool -- AZ:Needed? is in first field of eFunId
             , epStack     :: (ColOffset,ColDelta) -- ^ stack of offsets that currently apply
             , epSrcSpan  :: GHC.SrcSpan
             }

type EP a = RWS EPLocal (Endo String) EPState a

runEP :: EP () -> GHC.SrcSpan -> Anns -> String
runEP f ss ans =
  flip appEndo "" . snd . execRWS f (defaultLocal ss) $ (defaultState ans)

defaultState :: Anns -> EPState
defaultState as = EPState
             { epPos    = (1,1)
             , epAnns   = as
             , epAnnKds = []
             }

defaultLocal :: GHC.SrcSpan -> EPLocal
defaultLocal ss = EPLocal
             { eFunId      = (False, "")
             , eFunIsInfix = False
             , epStack     = (0,0)
             , epSrcSpan   = ss
             }

getPos :: EP Pos
getPos = gets epPos

setPos :: Pos -> EP ()
setPos l = modify (\s -> s {epPos = l})

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

-- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous
-- offset
--
withOffset :: Annotation -> (EP () -> EP ())
withOffset a@(Ann (DP (edLine, edColumn)) newline originalStartCol annDelta _) k = do
  -- The colOffset is the offset to be used when going to the next line.
  -- The colIndent is how far the current code block has been indented.
  (colOffset, colIndent) <- asks epStack
  (_l, currentColumn) <- getPos
  let
      -- Add extra indentation for this SrcSpan
     colOffset' = annDelta + colOffset
     -- Work out where new column starts, based on the entry delta
     newStartColumn = if edLine == 0
                          then edColumn + currentColumn -- same line, use entry delta
                          else colOffset -- different line, use current offset
     newColIndent        = newStartColumn - originalStartCol

     offsetValNewIndent  = (colOffset' + (newColIndent - colIndent), newColIndent)
     offsetValSameIndent = (colOffset'            ,                  colIndent)
     offsetValNewline    = (annDelta   + colIndent,                  colIndent)

     newOffset =
        case newline of
          -- For use by AST modifiers, to preserve the indentation
          -- level for the next line after an AST modification
          KeepOffset  -> offsetValNewline

          -- Generated during the annotation phase
          LineChanged       -> offsetValNewline
          LayoutLineChanged -> offsetValNewline

          LineSame          -> offsetValSameIndent
          LayoutLineSame    -> offsetValNewIndent
  local (\s -> s {epStack = newOffset }) k
    `debug` ("pushOffset:(a, colOffset, colIndent, currentColumn, newOffset)="
                 ++ show (a, colOffset, colIndent, currentColumn, newOffset))

-- |Get the current column offset
getOffset :: EP ColOffset
getOffset = asks (fst . epStack)

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

withSrcSpan :: GHC.SrcSpan -> (EP () -> EP ())
withSrcSpan ss = local (\s -> s {epSrcSpan = ss})

getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)
getAndRemoveAnnotation a = do
  (r, an') <- gets (getAndRemoveAnnotationEP a . epAnns)
  modify (\s -> s { epAnns = an' })
  return r

withKds :: [(KeywordId, DeltaPos)] -> EP () -> EP ()
withKds kd action = do
  modify (\s -> s { epAnnKds = kd : (epAnnKds s) })
  action
  modify (\s -> s { epAnnKds = tail (epAnnKds s) })

-- | Get and remove the first item in the (k,v) list for which the k matches.
-- Return the value, together with any comments skipped over to get there.
destructiveGetFirst :: KeywordId -> ([(KeywordId,v)],[(KeywordId,v)])
                    -> ([(KeywordId,v)],[v],[(KeywordId,v)])
destructiveGetFirst _key (acc,[]) = ([],[],acc)
destructiveGetFirst  key (acc,((k,v):kvs))
  | k == key = let (cs,others) = commentsAndOthers acc in (cs,[v],others++kvs)
  | otherwise = destructiveGetFirst key (acc++[(k,v)],kvs)
  where
    commentsAndOthers kvs' = partition isComment kvs'
    isComment ((AnnComment _),_) = True
    isComment _              = False

-- |destructive get, hence use an annotation once only
getAnnFinal :: KeywordId -> EP ([DComment], [DeltaPos])
getAnnFinal kw = do
  kd <- gets epAnnKds
  let (r, kd', dcs) = case kd of
                  []    -> ([],[], [])
                  (k:kds) -> (r',kk:kds, dcs')
                    where (cs', r',kk) = destructiveGetFirst kw ([],k)
                          dcs' = concatMap keywordIdToDComment cs'
  modify (\s -> s { epAnnKds = kd' })
  return (dcs, r)

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

getStoredListSrcSpan :: EP GHC.SrcSpan
getStoredListSrcSpan = do
  kd <- gets epAnnKds
  let
    isAnnList ((AnnList _),_) = True
    isAnnList _               = False

    kdf = ghead "getStoredListSrcSpan.1" kd
    (AnnList ss,_) = ghead "getStoredListSrcSpan.2" $ filter isAnnList kdf
  return ss

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

keywordIdToDComment :: (KeywordId, DeltaPos) -> [DComment]
keywordIdToDComment (AnnComment comment,_dp) = [comment]
keywordIdToDComment _                   = []

-- |non-destructive get
peekAnnFinal :: KeywordId -> EP [DeltaPos]
peekAnnFinal kw = do
  (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds)
  return r

getFunId :: EP (Bool,String)
getFunId = asks eFunId

withFunId :: (Bool,String) -> (EP () -> EP ())
withFunId st = local (\s -> s{eFunId = st})

getFunIsInfix :: EP Bool
getFunIsInfix = asks eFunIsInfix

withFunIsInfix :: Bool -> (EP () -> EP ())
withFunIsInfix b = local (\s -> s {eFunIsInfix = b})

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

printString :: String -> EP ()
printString str = do
  (l,c) <- gets epPos
  setPos (l, c + length str)
  tell (Endo $ showString str)

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 ()

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

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

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

-- |This should be the final point where things are mode concrete,
-- before output. Hence the point where comments can be inserted
printStringAtLsDelta :: [DComment] -> [DeltaPos] -> String -> EP ()
printStringAtLsDelta cs mc s =
  case reverse mc of
    (cl:_) -> do
      p <- getPos
      colOffset <- getOffset
      if isGoodDeltaWithOffset cl colOffset
        then do
          mapM_ printQueuedComment cs
          printStringAt (undelta p cl colOffset) s
            `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))
        else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (mc,s))
    _ -> return ()


isGoodDeltaWithOffset :: DeltaPos -> Int -> Bool
isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset))

-- AZ:TODO: harvest the commonality between this and printStringAtLsDelta
printQueuedComment :: DComment -> EP ()
printQueuedComment (DComment (dp,de) s) = do
  p <- getPos
  colOffset <- getOffset
  let (dr,dc) = undelta (0,0) dp colOffset
  if isGoodDelta (DP (dr,max 0 dc)) -- do not lose comments against the left margin
    then do
      printStringAt (undelta p dp colOffset) s
         `debug` ("printQueuedComment:(pos,s):" ++ show (undelta p dp colOffset,s))
      setPos (undelta p de colOffset)
    else return () `debug` ("printQueuedComment::bad delta for (dp,s):" ++ show (dp,s))

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

getPosForDelta :: DeltaPos -> EP Pos
getPosForDelta dp = do
  p <- getPos
  colOffset <- getOffset
  return (undelta p dp colOffset)

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

printStringAtMaybeAnn :: KeywordId -> String -> EP ()
printStringAtMaybeAnn an str = do
  (comments, ma) <- getAnnFinal an
  printStringAtLsDelta comments ma str
    `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str))

printStringAtMaybeAnnAll :: KeywordId -> String -> EP ()
printStringAtMaybeAnnAll an str = go
  where
    go = do
      (comments, ma) <- getAnnFinal an
      case ma of
        [] -> return ()
        [d]  -> printStringAtLsDelta comments [d] str >> go

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

countAnns :: KeywordId -> EP Int
countAnns an = do
  ma <- peekAnnFinal an
  return (length ma)

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

-- | Print an AST exactly as specified by the annotations on the nodes in the tree.
-- exactPrint :: (ExactP ast) => ast -> [Comment] -> String
exactPrint :: (ExactP ast) => GHC.Located ast -> String
exactPrint ast@(GHC.L l _) = runEP (exactPC ast) l Map.empty


exactPrintAnnotated ::
     GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> String
exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (exactPC ast) l an
  where
    an = annotateLHsModule ast ghcAnns

exactPrintAnnotation :: ExactP ast =>
  GHC.Located ast -> Anns -> String
exactPrintAnnotation ast@(GHC.L l _) an = runEP (exactPC ast) l an
  -- `debug` ("exactPrintAnnotation:an=" ++ (concatMap (\(l,a) -> show (ss2span l,a)) $ Map.toList an ))

annotateAST :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> Anns
annotateAST ast ghcAnns = annotateLHsModule ast ghcAnns


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

-- |First move to the given location, then call exactP
exactPC :: (ExactP ast) => GHC.Located ast -> EP ()
exactPC a@(GHC.L l ast) =
    do return () `debug` ("exactPC entered for:" ++ showGhc l)
       ma <- getAndRemoveAnnotation a
       let an@(Ann _edp _nl _sc _dc kds) = fromMaybe annNone ma
       withContext kds l an
        (do
          exactP ast
          printStringAtMaybeAnn (G GHC.AnnComma) ","
          printStringAtMaybeAnnAll AnnSemiSep ";")
       epStack' <- asks epStack
       return () `debug` ("popOffset:after pop:(l,epStack')=" ++ showGhc (l,epStack'))

withContext :: [(KeywordId, DeltaPos)]
            -> GHC.SrcSpan
            -> Annotation
            -> (EP () -> EP ())
withContext kds l an = withKds kds . withSrcSpan l . withOffset an

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

printMerged :: (ExactP a, ExactP b) => [GHC.Located a] -> [GHC.Located b] -> EP ()
printMerged [] [] = return ()
printMerged [] bs = mapM_ exactPC bs
printMerged as [] = mapM_ exactPC as
printMerged (a@(GHC.L l1 _):as) (b@(GHC.L l2 _):bs) =
  if l1 < l2
    then exactPC a >> printMerged    as (b:bs)
    else exactPC b >> printMerged (a:as)   bs

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

prepareListPrint :: ExactP ast
                 => [GHC.GenLocated GHC.SrcSpan ast] -> [(GHC.SrcSpan, EP ())]
prepareListPrint ls = map (\b@(GHC.L l _) -> (l,exactPC b)) ls

applyListPrint :: (Monad m, Ord a) => [(a, m b)] -> m ()
applyListPrint ls = mapM_ (\(_,b) -> b) $ sortBy (\(a,_) (b,_) -> compare a b) ls

-- ---------------------------------------------------------------------
-- Exact printing for GHC

class (Data ast) => ExactP ast where
  -- | Print an AST fragment. The correct position in output is
  -- already established.
  exactP :: ast -> EP ()

instance ExactP (GHC.HsModule GHC.RdrName) where
  exactP (GHC.HsModule mmn mexp imps decls mdepr _haddock) = do

    case mmn of
      Just (GHC.L _ mn) -> do
        printStringAtMaybeAnn (G GHC.AnnModule) "module" -- `debug` ("exactP.HsModule:cs=" ++ show cs)
        printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn)
      Nothing -> return ()

    case mdepr of
      Nothing -> return ()
      Just depr -> exactPC depr

    case mexp of
      Just lexps -> do
        return () `debug` ("about to exactPC lexps")
        exactPC lexps
        return ()
      Nothing -> return ()

    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC)  "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" -- possible leading semis
    exactP imps

    mapM_ exactPC decls

    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

    -- put the end of file whitespace in
    printStringAtMaybeAnn (G GHC.AnnEofPos) ""

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

instance ExactP GHC.WarningTxt where
  exactP (GHC.WarningTxt (GHC.L _ ls) lss) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) ls
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    mapM_ exactPC lss
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.DeprecatedTxt (GHC.L _ ls) lss) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) ls
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    mapM_ exactPC lss
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

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

instance ExactP (GHC.ModuleName) where
  exactP mn = do
    printString (GHC.moduleNameString mn)

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

instance ExactP [GHC.LIE GHC.RdrName] where
  exactP ies = do
    printStringAtMaybeAnn (G GHC.AnnHiding) "hiding"
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    mapM_ exactPC ies
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

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

instance ExactP (GHC.IE GHC.RdrName) where
  exactP (GHC.IEVar ln) = do
    printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
    printStringAtMaybeAnn (G GHC.AnnType)    "type"
    exactPC ln

  exactP (GHC.IEThingAbs n) = do
    printStringAtMaybeAnn (G GHC.AnnType)    "type"
    exactPC n

  exactP (GHC.IEThingWith n ns) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnOpenP)    "("
    mapM_ exactPC ns
    printStringAtMaybeAnn (G GHC.AnnCloseP)   ")"

  exactP (GHC.IEThingAll n) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnOpenP)   "("
    printStringAtMaybeAnn (G GHC.AnnDotdot)  ".."
    printStringAtMaybeAnn (G GHC.AnnCloseP)  ")"

  exactP (GHC.IEModuleContents (GHC.L _ mn)) = do
    printStringAtMaybeAnn (G GHC.AnnModule)  "module"
    printStringAtMaybeAnn (G GHC.AnnVal)     (GHC.moduleNameString mn)

  exactP x = printString ("no exactP.IE for " ++ showGhc (x))

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

instance ExactP [GHC.LImportDecl GHC.RdrName] where
  exactP imps = mapM_ exactPC imps

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

instance ExactP (GHC.ImportDecl GHC.RdrName) where
  exactP imp = do
    printStringAtMaybeAnn (G GHC.AnnImport) "import"

    printStringAtMaybeAnn (G GHC.AnnOpen)  "{-# SOURCE"
    printStringAtMaybeAnn (G GHC.AnnClose)  "#-}"

    printStringAtMaybeAnn (G GHC.AnnSafe)      "safe"
    printStringAtMaybeAnn (G GHC.AnnQualified) "qualified"
    printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp)

    case GHC.ideclAs imp of
      Nothing -> return ()
      Just mn -> do
        printStringAtMaybeAnn (G GHC.AnnAs) "as"
        printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn)

    case GHC.ideclHiding imp of
      Nothing -> return ()
      Just (_,lie) -> do
        -- printStringAtMaybeAnn (G GHC.AnnHiding "hiding"
        exactPC lie

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

doMaybe :: (Monad m) => (a -> m ()) -> Maybe a -> m ()
doMaybe f ma = case ma of
                 Nothing -> return ()
                 Just a -> f a

instance ExactP (GHC.HsDecl GHC.RdrName) where
  exactP decl = case decl of
    GHC.TyClD d       -> exactP d
    GHC.InstD d       -> exactP d
    GHC.DerivD d      -> exactP d
    GHC.ValD d        -> exactP d
    GHC.SigD d        -> exactP d
    GHC.DefD d        -> exactP d
    GHC.ForD d        -> exactP d
    GHC.WarningD d    -> exactP d
    GHC.AnnD d        -> exactP d
    GHC.RuleD d       -> exactP d
    GHC.VectD d       -> exactP d
    GHC.SpliceD d     -> exactP d
    GHC.DocD d        -> exactP d
    GHC.QuasiQuoteD d -> exactP d
    GHC.RoleAnnotD d  -> exactP d

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

instance ExactP (GHC.RoleAnnotDecl GHC.RdrName) where
  exactP (GHC.RoleAnnotDecl ln mr) = do
    printStringAtMaybeAnn (G GHC.AnnType) "type"
    printStringAtMaybeAnn (G GHC.AnnRole) "role"
    exactPC ln
    mapM_ exactPC mr

instance ExactP (Maybe GHC.Role) where
  exactP Nothing  = printStringAtMaybeAnn (G GHC.AnnVal) "_"
  exactP (Just r) = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS $ GHC.fsFromRole r)

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

instance ExactP (GHC.HsQuasiQuote GHC.RdrName) where
  exactP = assert False undefined

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

instance ExactP (GHC.SpliceDecl GHC.RdrName) where
  exactP (GHC.SpliceDecl (GHC.L _ (GHC.HsSplice _n e)) flag) = do
    case flag of
      GHC.ExplicitSplice ->
        printStringAtMaybeAnn (G GHC.AnnOpen) "$("
      GHC.ImplicitSplice ->
        printStringAtMaybeAnn (G GHC.AnnOpen) "$$("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) ")"

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

instance ExactP (GHC.VectDecl GHC.RdrName) where
  exactP (GHC.HsVect src ln e) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE"
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.HsNoVect src ln) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# NOVECTORISE"
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.HsVectTypeIn src _b ln mln) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR"
    printStringAtMaybeAnn (G GHC.AnnType) "type"
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    case mln of
      Nothing -> return ()
      Just n -> exactPC n
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.HsVectTypeOut {}) = error $ "exactP.HsVectTypeOut: only valid after type checker"

  exactP (GHC.HsVectClassIn src ln) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE"
    printStringAtMaybeAnn (G GHC.AnnClass) "class"
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.HsVectClassOut {}) = error $ "exactP.HsVectClassOut: only valid after type checker"
  exactP (GHC.HsVectInstIn {})   = error $ "exactP.HsVectInstIn: not supported?"
  exactP (GHC.HsVectInstOut {})  = error $ "exactP.HsVectInstOut: not supported?"


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

instance ExactP (GHC.RuleDecls GHC.RdrName) where
  exactP (GHC.HsRules src rules) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    mapM_ exactPC rules
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

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

instance ExactP (GHC.AnnDecl GHC.RdrName) where
  exactP (GHC.HsAnnotation src prov e) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnType) "type"
    printStringAtMaybeAnn (G GHC.AnnModule) "module"
    case prov of
      (GHC.ValueAnnProvenance n) -> exactPC n
      (GHC.TypeAnnProvenance n) -> exactPC n
      (GHC.ModuleAnnProvenance) -> return ()
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

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

instance ExactP (GHC.RuleDecl GHC.RdrName) where
  exactP (GHC.HsRule ln act bndrs lhs _ rhs _) = do
    exactPC ln
    -- activation
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    printStringAtMaybeAnn (G GHC.AnnTilde) "~"
    case act of
      GHC.ActiveBefore n -> printStringAtMaybeAnn (G GHC.AnnVal) (show n)
      GHC.ActiveAfter n  -> printStringAtMaybeAnn (G GHC.AnnVal) (show n)
      _                  -> return ()
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

    printStringAtMaybeAnn (G GHC.AnnForall) "forall"
    mapM_ exactPC bndrs
    printStringAtMaybeAnn (G GHC.AnnDot) "."

    exactPC lhs
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC rhs

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

instance ExactP (GHC.RuleBndr GHC.RdrName) where
  exactP (GHC.RuleBndr ln) = exactPC ln
  exactP (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC thing
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

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

instance ExactP (GHC.WarnDecls GHC.RdrName) where
  exactP (GHC.Warnings src warns) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    mapM_ exactPC warns
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

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

instance ExactP (GHC.WarnDecl GHC.RdrName) where
  exactP (GHC.Warning lns txt) = do
     mapM_ exactPC lns
     printStringAtMaybeAnn (G GHC.AnnOpenS) "["
     case txt of
       -- TODO: AZ: why are we ignoring src?
       GHC.WarningTxt    src ls -> mapM_ exactPC ls
       GHC.DeprecatedTxt src ls -> mapM_ exactPC ls
     printStringAtMaybeAnn (G GHC.AnnCloseS) "]"


instance ExactP GHC.FastString where
  exactP fs = printStringAtMaybeAnn (G GHC.AnnVal) (show (GHC.unpackFS fs))

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

instance ExactP (GHC.ForeignDecl GHC.RdrName) where
  exactP (GHC.ForeignImport ln typ _
               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L _ src))) = do
    printStringAtMaybeAnn (G GHC.AnnForeign) "foreign"
    printStringAtMaybeAnn (G GHC.AnnImport) "import"

    exactPC cconv

    if ll == GHC.noSrcSpan
      then return ()
      else exactPC safety

    printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"")
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

  exactP (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L _ src))) = do
    printStringAtMaybeAnn (G GHC.AnnForeign) "foreign"
    printStringAtMaybeAnn (G GHC.AnnExport) "export"
    exactPC spec
    printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"")
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

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

instance (ExactP GHC.CExportSpec) where
  exactP (GHC.CExportStatic _ cconv) = exactP cconv

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

instance ExactP GHC.CCallConv where
  exactP GHC.StdCallConv        = printStringAtMaybeAnn (G GHC.AnnVal) "stdcall"
  exactP GHC.CCallConv          = printStringAtMaybeAnn (G GHC.AnnVal) "ccall"
  exactP GHC.CApiConv           = printStringAtMaybeAnn (G GHC.AnnVal) "capi"
  exactP GHC.PrimCallConv       = printStringAtMaybeAnn (G GHC.AnnVal) "prim"
  exactP GHC.JavaScriptCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "javascript"

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

instance ExactP GHC.Safety where
  exactP GHC.PlayRisky         = printStringAtMaybeAnn (G GHC.AnnVal) "unsafe"
  exactP GHC.PlaySafe          = printStringAtMaybeAnn (G GHC.AnnVal) "safe"
  exactP GHC.PlayInterruptible = printStringAtMaybeAnn (G GHC.AnnVal) "interruptible"


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

instance ExactP (GHC.DerivDecl GHC.RdrName) where
  exactP (GHC.DerivDecl typ mov) = do
    printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving"
    printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
    case mov of
      Nothing -> return ()
      Just ov -> exactPC ov
    exactPC typ

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

instance ExactP (GHC.DefaultDecl GHC.RdrName) where
  exactP (GHC.DefaultDecl typs) = do
    printStringAtMaybeAnn (G GHC.AnnDefault) "default"
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    mapM_ exactPC typs
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

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

instance ExactP (GHC.InstDecl GHC.RdrName) where
  exactP (GHC.ClsInstD      cid) = exactP  cid
  exactP (GHC.DataFamInstD dfid) = exactP dfid
  exactP (GHC.TyFamInstD   tfid) = exactP tfid

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

instance ExactP GHC.OverlapMode where
  exactP (GHC.NoOverlap src) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.Overlappable src) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.Overlapping src) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.Overlaps src) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

  exactP (GHC.Incoherent src) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"


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

instance ExactP (GHC.ClsInstDecl GHC.RdrName) where
  exactP (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do
    printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
    case mov of
      Nothing -> return ()
      Just ov -> exactPC ov
    exactPC poly
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"

    applyListPrint (prepareListPrint (GHC.bagToList binds)
                 ++ prepareListPrint sigs
                 ++ prepareListPrint tyfams
                 ++ prepareListPrint datafams
                    )
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

instance ExactP (GHC.TyFamInstDecl GHC.RdrName) where
   exactP (GHC.TyFamInstDecl eqn _) = do
     printStringAtMaybeAnn (G GHC.AnnType)     "type"
     printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
     exactPC eqn

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

instance ExactP (GHC.DataFamInstDecl GHC.RdrName) where
   exactP (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _)
            (GHC.HsDataDefn _nOrD _ctx _mtyp mkind cons mderivs) _) = do
    printStringAtMaybeAnn (G GHC.AnnData)     "data"
    printStringAtMaybeAnn (G GHC.AnnNewtype)  "newtype"
    printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
    exactPC ln
    mapM_ exactPC pats

    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    doMaybe exactPC mkind

    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnEqual) "="

    mapM_ exactPC cons
    doMaybe exactPC mderivs

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

instance ExactP (GHC.HsBind GHC.RdrName) where
  exactP (GHC.FunBind (GHC.L _ n) isInfix  (GHC.MG matches _ _ _) _ _ _) = do
    withFunId (isSymbolRdrName n,rdrName2String n) (
      withFunIsInfix isInfix
        (mapM_ exactPC matches))

  exactP (GHC.PatBind lhs (GHC.GRHSs grhs lb) _ty _fvs _ticks) = do
    exactPC lhs
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    mapM_ exactPC grhs
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    -- exactP lb
    exactPC (GHC.L (getLocalBindsSrcSpan lb) lb)


  exactP (GHC.VarBind _var_id _var_rhs _var_inline ) = printString "VarBind"
  exactP (GHC.AbsBinds _abs_tvs _abs_ev_vars _abs_exports _abs_ev_binds _abs_binds) = printString "AbsBinds"

  exactP (GHC.PatSynBind (GHC.PSB n _fvs args def dir)) = do
    printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
    exactPC n
    case args of
      GHC.InfixPatSyn na nb -> do
        exactPC na
        exactPC nb
      GHC.PrefixPatSyn ns -> do
        mapM_ exactPC ns

    printStringAtMaybeAnn (G GHC.AnnEqual)   "="
    printStringAtMaybeAnn (G GHC.AnnLarrow)  "<-"

    exactPC def
    case dir of
      GHC.Unidirectional           -> return ()
      GHC.ImplicitBidirectional    -> return ()
      GHC.ExplicitBidirectional mg -> exactPMatchGroup mg

    printStringAtMaybeAnn (G GHC.AnnWhere)   "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC)    "{"
    printStringAtMaybeAnn (G GHC.AnnCloseC)   "}"

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

instance ExactP (GHC.IPBind GHC.RdrName) where
  exactP (GHC.IPBind en e) = do
    case en of
      Left n -> exactPC n
      Right _i -> error $ "annotateP.IPBind:should not happen"
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC e

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

instance (ExactP body) => ExactP (GHC.Match GHC.RdrName (GHC.Located body)) where
  exactP (GHC.Match mln pats typ (GHC.GRHSs grhs lb)) = do
    (isSym,funid) <- getFunId
    isInfix <- getFunIsInfix
    let
      get_infix Nothing = isInfix
      get_infix (Just (_,f)) = f
    case (get_infix mln,pats) of
      (True,[a,b]) -> do
        exactPC a
        case mln of
          Nothing -> do
            if isSym
              then printStringAtMaybeAnn (G GHC.AnnFunId) funid
              else printStringAtMaybeAnn (G GHC.AnnFunId) ("`"++ funid ++ "`")
          Just (n,_) -> exactPC n
        exactPC b
      _ -> do
        case mln of
          Nothing -> printStringAtMaybeAnn (G GHC.AnnFunId) funid
          Just (n,_)  -> exactPC n
        mapM_ exactPC pats
    printStringAtMaybeAnn (G GHC.AnnEqual)  "="
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->" -- for HsLam
    mapM_ exactPC typ
    mapM_ exactPC grhs
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
    -- exactP lb
    exactPC (GHC.L (getLocalBindsSrcSpan lb) lb)
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

instance ExactP (GHC.Pat GHC.RdrName) where

  exactP (GHC.WildPat _) = printStringAtMaybeAnn (G GHC.AnnVal) "_"

  exactP (GHC.VarPat n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)

  exactP (GHC.LazyPat p)    = do
    printStringAtMaybeAnn (G GHC.AnnTilde) "~"
    exactPC p

  exactP (GHC.AsPat n p) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnAt) "@"
    exactPC p

  exactP (GHC.ParPat p) = do
    return () `debug` ("in exactP.ParPat")
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    exactPC p
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

  exactP (GHC.BangPat p) = do
    printStringAtMaybeAnn (G GHC.AnnBang) "!"
    exactPC p

  exactP (GHC.ListPat ps _ _) = do
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    mapM_ exactPC ps
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

  exactP (GHC.TuplePat pats b _) = do
    if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "("
                      else printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
    mapM_ exactPC pats
    if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
                      else printStringAtMaybeAnn (G GHC.AnnClose) "#)"

  exactP (GHC.PArrPat ps _) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
    mapM_ exactPC ps
    printStringAtMaybeAnn (G GHC.AnnClose) ":]"

  exactP (GHC.ConPatIn n dets) = do
    case dets of
      GHC.PrefixCon args -> do
        exactPC n
        mapM_ exactPC args
      GHC.RecCon (GHC.HsRecFields fs _) -> do
        exactPC n
        printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
        mapM_ exactPC fs
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
        printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
      GHC.InfixCon a1 a2 -> do
        exactPC a1
        exactPC n
        exactPC a2

  exactP (GHC.ConPatOut {}) = return ()

  exactP (GHC.ViewPat e pat _) = do
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
    exactPC pat

  exactP (GHC.SplicePat (GHC.HsSplice _ e)) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "$("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) ")"

  exactP (GHC.QuasiQuotePat (GHC.HsQuasiQuote n _ q)) = do
    printStringAtMaybeAnn (G GHC.AnnVal)
                    ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")

  exactP (GHC.LitPat lp) = do
    printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lp)

  exactP (GHC.NPat ol _ _)  = do
    printStringAtMaybeAnn (G GHC.AnnMinus) "-"
    exactPC ol

  exactP (GHC.NPlusKPat ln ol _ _) = do
    exactPC ln
    printStringAtMaybeAnn (G GHC.AnnVal) "+"
    exactPC ol

  exactP (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do
    exactPC pat
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC ty

  exactP (GHC.SigPatOut {}) = return ()
  exactP (GHC.CoPat {}) = return ()

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

instance ExactP (GHC.HsType GHC.Name) where
  exactP typ = do
    return () `debug` ("exactP.HsType not implemented for " ++ showGhc (typ))
    printString "HsType.Name"
    -- Note: This should never appear, only the one for GHC.RdrName
    assert False undefined

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

instance ExactP (GHC.HsType GHC.RdrName) where
  exactP (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP)   "("
    printStringAtMaybeAnn (G GHC.AnnForall) "forall"
    mapM_ exactPC tvs
    printStringAtMaybeAnn (G GHC.AnnDot)    "."

    case mwc of
      Nothing -> exactPC ctx
      Just lwc  -> exactPC (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs)))

    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
    exactPC typ
    printStringAtMaybeAnn (G GHC.AnnCloseP)  ")"

  exactP (GHC.HsTyVar n) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    exactP n

  exactP (GHC.HsAppTy t1 t2) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    exactPC t1
    exactPC t2

  exactP (GHC.HsFunTy t1 t2) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    exactPC t1
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
    exactPC t2

  exactP (GHC.HsListTy t) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    printStringAtMaybeAnn (G GHC.AnnOpenS)  "["
    exactPC t
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

  exactP (GHC.HsPArrTy t) = do
    printStringAtMaybeAnn (G GHC.AnnOpen)  "[:"
    exactPC t
    printStringAtMaybeAnn (G GHC.AnnClose) ":]"

  exactP (GHC.HsTupleTy _tsort ts) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    printStringAtMaybeAnn (G GHC.AnnOpen)  "(#"
    mapM_ exactPC ts
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
    printStringAtMaybeAnn (G GHC.AnnClose)  "#)"

  exactP (GHC.HsOpTy t1 (_,op) t2) = do
    exactPC t1
    exactPC op
    exactPC t2

  exactP (GHC.HsParTy t1) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    printStringAtMaybeAnn (G GHC.AnnOpenP)  "("
    exactPC t1
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

  exactP (GHC.HsIParamTy (GHC.HsIPName n) t) = do
    printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ (GHC.unpackFS n))
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC t

  exactP (GHC.HsEqTy t1 t2) = do
    exactPC t1
    printStringAtMaybeAnn (G GHC.AnnTilde) "~"
    exactPC t2

  exactP (GHC.HsKindSig t k) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP)  "("
    exactPC t
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC k
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

  exactP (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote n _ss q)) = do
    printStringAtMaybeAnn (G GHC.AnnVal)
                    ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")

  exactP (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do
    printStringAtMaybeAnn (G GHC.AnnOpen)  "$("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) ")"

  exactP (GHC.HsDocTy t d) = do
    exactPC t
    exactPC d

  exactP (GHC.HsBangTy b t) = do
    case b of
      (GHC.HsSrcBang ms (Just True) _) -> do
        printStringAtMaybeAnn (G GHC.AnnOpen)  (maybe "{-# UNPACK" id ms)
        printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
        printStringAtMaybeAnn (G GHC.AnnBang)  "!"
      (GHC.HsSrcBang ms (Just False) _) -> do
        printStringAtMaybeAnn (G GHC.AnnOpen)  (maybe "{-# NOUNPACK" id ms)
        printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
        printStringAtMaybeAnn (G GHC.AnnBang)  "!"
      _ -> do
        printStringAtMaybeAnn (G GHC.AnnBang)  "!"
    exactPC t

  exactP (GHC.HsRecTy cons) = do
    printStringAtMaybeAnn (G GHC.AnnOpenC)  "{"
    mapM_ exactPC cons
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.HsCoreTy _t) = return ()

  exactP (GHC.HsExplicitListTy _ ts) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    printStringAtMaybeAnn (G GHC.AnnOpen)  "'["
    mapM_ exactPC ts
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

  exactP (GHC.HsExplicitTupleTy _ ts) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    printStringAtMaybeAnn (G GHC.AnnOpen)  "'("
    mapM_ exactPC ts
    printStringAtMaybeAnn (G GHC.AnnClose) ")"

  exactP (GHC.HsTyLit lit) = do
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType
    case lit of
      (GHC.HsNumTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s
      (GHC.HsStrTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s

  exactP (GHC.HsWrapTy _ _) = return ()

  exactP GHC.HsWildcardTy = do
    printStringAtMaybeAnn (G GHC.AnnVal) "_"
    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" -- if only part of a partial type signature context

  exactP (GHC.HsNamedWildcardTy n) = do
    printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)

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

instance ExactP GHC.HsDocString where
  exactP (GHC.HsDocString s) = do
    printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS s)

instance ExactP (GHC.ConDeclField GHC.RdrName) where
  exactP (GHC.ConDeclField ns ty mdoc) = do
    mapM_ exactPC ns
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC ty
    case mdoc of
      Just doc -> exactPC doc
      Nothing -> return ()

instance ExactP (GHC.HsContext GHC.RdrName) where
  exactP typs = do
    -- printStringAtMaybeAnn (G GHC.AnnUnit "()"

    printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving"
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    mapM_ exactPC typs
    -- printStringAtMaybeAnn (G GHC.AnnUnit "()"
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"

instance (ExactP body) => ExactP (GHC.GRHS GHC.RdrName (GHC.Located body)) where
  exactP (GHC.GRHS guards expr) = do
    printStringAtMaybeAnn (G GHC.AnnVbar) "|"
    mapM_ exactPC guards
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->" -- in a case
    exactPC expr

instance (ExactP body)
  => ExactP (GHC.Stmt GHC.RdrName (GHC.Located body)) where

  exactP (GHC.LastStmt body _) = exactPC body
    `debug` ("exactP.LastStmt")

  exactP (GHC.BindStmt pat body _ _) = do
    exactPC pat
    printStringAtMaybeAnn (G GHC.AnnLarrow) "<-"
    exactPC body
    printStringAtMaybeAnn (G GHC.AnnVbar)  "|" -- possible in list comprehension

  exactP (GHC.BodyStmt e _ _ _) = do
    exactPC e

  exactP (GHC.LetStmt lb) = do
    printStringAtMaybeAnn (G GHC.AnnLet) "let"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    exactPC (GHC.L (getLocalBindsSrcSpan lb) lb)
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.ParStmt pbs _ _) = do
    mapM_ exactPParStmtBlock pbs

  exactP (GHC.TransStmt form stmts _b using by _ _ _) = do
    mapM_ exactPC stmts
    case form of
      GHC.ThenForm -> do
        printStringAtMaybeAnn (G GHC.AnnThen) "then"
        exactPC using
        printStringAtMaybeAnn (G GHC.AnnBy) "by"
        case by of
          Just b -> exactPC b
          Nothing -> return ()
      GHC.GroupForm -> do
        printStringAtMaybeAnn (G GHC.AnnThen)  "then"
        printStringAtMaybeAnn (G GHC.AnnGroup) "group"
        printStringAtMaybeAnn (G GHC.AnnBy)    "by"
        case by of
          Just b -> exactPC b
          Nothing -> return ()
        printStringAtMaybeAnn (G GHC.AnnUsing) "using"
        exactPC using

  exactP (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do
    printStringAtMaybeAnn (G GHC.AnnRec) "rec"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
    mapM_ exactPC stmts
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

exactPParStmtBlock :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> EP ()
exactPParStmtBlock (GHC.ParStmtBlock stmts _ns _) = do
  mapM_ exactPC stmts

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

instance ExactP (GHC.HsExpr GHC.RdrName) where
  exactP (GHC.HsVar v)  = exactP v
  exactP (GHC.HsIPVar (GHC.HsIPName v)) = do
    printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS v)
  exactP (GHC.HsOverLit lit)     = exactP lit
  exactP (GHC.HsLit lit)         = exactP lit
  exactP (GHC.HsLam match)       = do
    printStringAtMaybeAnn (G GHC.AnnLam) "\\"
    exactPMatchGroup match
  exactP (GHC.HsLamCase _ match) = exactPMatchGroup match
  exactP (GHC.HsApp e1 e2)       = exactPC e1 >> exactPC e2
  exactP (GHC.OpApp e1 op _f e2) = exactPC e1 >> exactPC op >> exactPC e2

  exactP (GHC.NegApp e _)        = do
    printStringAtMaybeAnn (G GHC.AnnMinus) "-"
    exactPC e

  exactP (GHC.HsPar e) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP)  "("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

  exactP (GHC.SectionL e1 e2)    = exactPC e1 >> exactPC e2
  exactP (GHC.SectionR e1 e2)    = exactPC e1 >> exactPC e2

  exactP (GHC.ExplicitTuple args b) = do
    if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "("
                      else printStringAtMaybeAnn (G GHC.AnnOpen) "(#"

    mapM_ exactPC args `debug` ("exactP.ExplicitTuple")

    if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
                      else printStringAtMaybeAnn (G GHC.AnnClose) "#)"

  exactP (GHC.HsCase e1 matches) = do
    printStringAtMaybeAnn (G GHC.AnnCase) "case"
    exactPC e1
    printStringAtMaybeAnn (G GHC.AnnOf) "of"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
    exactPMatchGroup matches
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.HsIf _ e1 e2 e3)   = do
    printStringAtMaybeAnn (G GHC.AnnIf) "if"
    exactPC e1
    printStringAtMaybeAnn (G GHC.AnnSemi) ";"
    printStringAtMaybeAnn (G GHC.AnnThen) "then"
    exactPC e2
    printStringAtMaybeAnn (G GHC.AnnSemi) ";"
    printStringAtMaybeAnn (G GHC.AnnElse) "else"
    exactPC e3

  exactP (GHC.HsMultiIf _ rhs)   = do
    printStringAtMaybeAnn (G GHC.AnnIf) "if"
    mapM_ exactPC rhs

  exactP (GHC.HsLet lb e)    = do
    return () `debug` ("exactP.HsLet started")
    printStringAtMaybeAnn (G GHC.AnnLet) "let"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
    exactPC (GHC.L (getLocalBindsSrcSpan lb) lb)
    return () `debug` ("exactP.HsLet lb done")
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
    printStringAtMaybeAnn (G GHC.AnnIn) "in"
    exactPC e
    return () `debug` ("exactP.HsLet ended")

  exactP (GHC.HsDo cts stmts _typ)    = do
    printStringAtMaybeAnn (G GHC.AnnDo) "do"
    let (ostr,cstr,isComp) =
          if isListComp cts
            then case cts of
                   GHC.PArrComp -> ("[:",":]",True)
                   _            -> ("[",  "]",True)
            else ("{","}",False)

    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    printStringAtMaybeAnn (G GHC.AnnOpen) ostr
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
    if isComp
      then do
        exactPC(last stmts)
        printStringAtMaybeAnn (G GHC.AnnVbar) "|"
        mapM_ exactPC (init stmts)
      else do
        ss <- getStoredListSrcSpan
        exactPC (GHC.L ss stmts)
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
    printStringAtMaybeAnn (G GHC.AnnClose) cstr
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.ExplicitList _ _ es) = do
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    mapM_ exactPC es
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

  exactP (GHC.ExplicitPArr _ es)   = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
    mapM_ exactPC es
    printStringAtMaybeAnn (G GHC.AnnClose) ":]"

  exactP (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
    mapM_ exactPC fs
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  -- TODO: AZ: cons are not processed
  exactP (GHC.RecordUpd e (GHC.HsRecFields fs _) cons _ _)  = do
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
    mapM_ exactPC fs
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.ExprWithTySig e typ _) = do
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

  exactP (GHC.ExprWithTySigOut e typ) = do
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

  exactP (GHC.ArithSeq _ _ seqInfo) = do
    printStringAtMaybeAnn (G GHC.AnnOpenS) "["
    case seqInfo of
      GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
      GHC.FromTo e1 e2 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
        exactPC e2
      GHC.FromThen e1 e2 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnComma) ","
        exactPC e2
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
      GHC.FromThenTo e1 e2 e3 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnComma) ","
        exactPC e2
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
        exactPC e3
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"

  exactP (GHC.PArrSeq _ seqInfo) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
    case seqInfo of
      GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
      GHC.FromTo e1 e2 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
        exactPC e2
      GHC.FromThen e1 e2 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnComma) ","
        exactPC e2
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
      GHC.FromThenTo e1 e2 e3 -> do
        exactPC e1
        printStringAtMaybeAnn (G GHC.AnnComma) ","
        exactPC e2
        printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
        exactPC e3
    printStringAtMaybeAnn (G GHC.AnnClose) ":]"

  exactP (GHC.HsSCC src str e) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# SCC"
    printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str)
    printStringAtMaybeAnn (G GHC.AnnValStr) ("\"" ++ GHC.unpackFS str ++ "\"")
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
    exactPC e

  exactP (GHC.HsCoreAnn src str e) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# CORE"
    printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str)
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
    exactPC e

  exactP (GHC.HsBracket (GHC.VarBr single v)) = do
    if single then printStringAtMaybeAnn (G GHC.AnnVal) ("'"  ++ rdrName2String v)
              else printStringAtMaybeAnn (G GHC.AnnVal) ("''" ++ rdrName2String v)
  exactP (GHC.HsBracket (GHC.DecBrL ds)) = do
    cnt <- countAnns (G GHC.AnnOpen)
    case cnt of
      1 -> do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[d|"
        mapM_ exactPC ds
        printStringAtMaybeAnn (G GHC.AnnClose) "|]"
      _ -> do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[d|"
        printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
        mapM_ exactPC ds
        printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
        printStringAtMaybeAnn (G GHC.AnnClose) "|]"
  exactP (GHC.HsBracket (GHC.ExpBr e)) = do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[|"
        exactPC e
        printStringAtMaybeAnn (G GHC.AnnClose) "|]"
  exactP (GHC.HsBracket (GHC.TExpBr e)) = do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[||"
        exactPC e
        printStringAtMaybeAnn (G GHC.AnnClose) "||]"
  exactP (GHC.HsBracket (GHC.TypBr e)) = do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[t|"
        exactPC e
        printStringAtMaybeAnn (G GHC.AnnClose) "|]"
  exactP (GHC.HsBracket (GHC.PatBr e)) = do
        printStringAtMaybeAnn (G GHC.AnnOpen)  "[p|"
        exactPC e
        printStringAtMaybeAnn (G GHC.AnnClose) "|]"

  exactP (GHC.HsRnBracketOut _ _) = return ()
  exactP (GHC.HsTcBracketOut _ _) = return ()

  exactP (GHC.HsSpliceE False (GHC.HsSplice _ e)) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "$("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) ")"
  exactP (GHC.HsSpliceE True (GHC.HsSplice _ e)) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "$$("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnClose) ")"

  exactP (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote n _ str)) = do
    printStringAtMaybeAnn (G GHC.AnnVal)
          ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS str) ++ "|]")

  exactP (GHC.HsProc p c) = do
    printStringAtMaybeAnn (G GHC.AnnProc) "proc"
    exactPC p
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
    exactPC c

  exactP (GHC.HsStatic e) = do
    printStringAtMaybeAnn (G GHC.AnnStatic) "static"
    exactPC e

  exactP (GHC.HsArrApp e1 e2 _ _ _) = do
    exactPC e1
    -- only one of the next 4 will be resent
    printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<"
    printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-"
    printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<"
    printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-"

    exactPC e2

  exactP (GHC.HsArrForm e _ cs) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "(|"
    exactPC e
    mapM_ exactPC cs
    printStringAtMaybeAnn (G GHC.AnnClose)  "|)"

  exactP (GHC.HsTick _ _) = return ()
  exactP (GHC.HsBinTick _ _ _) = return ()

  exactP (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do
    -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
    printStringAtMaybeAnn (G GHC.AnnOpen)  src -- "{-# GENERATED"
    printStringAtMaybeAnn (G GHC.AnnVal)   (show $ GHC.unpackFS str)
    printStringAtMaybeAnn (G GHC.AnnVal)   (show v1)
    printStringAtMaybeAnn (G GHC.AnnColon) ":"
    printStringAtMaybeAnn (G GHC.AnnVal)   (show v2)
    printStringAtMaybeAnn (G GHC.AnnMinus) "-"
    printStringAtMaybeAnn (G GHC.AnnVal)   (show v3)
    printStringAtMaybeAnn (G GHC.AnnColon) ":"
    printStringAtMaybeAnn (G GHC.AnnVal)   (show v4)
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
    exactPC e

  exactP (GHC.EWildPat) = printStringAtMaybeAnn (G GHC.AnnVal) "_"

  exactP (GHC.EAsPat n e) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnAt) "@"
    exactPC e

  exactP (GHC.EViewPat e1 e2) = do
    exactPC e1
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
    exactPC e2

  exactP (GHC.ELazyPat e) = do
    printStringAtMaybeAnn (G GHC.AnnTilde) "~"
    exactPC e

  exactP (GHC.HsType ty) = exactPC ty
  exactP (GHC.HsWrap _ _) = return ()
  exactP (GHC.HsUnboundVar _) = return ()

  exactP e = printString "HsExpr"
    `debug` ("exactP.HsExpr:not processing " ++ (showGhc e) )

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

instance ExactP ([GHC.ExprLStmt GHC.RdrName]) where
  exactP ls = mapM_ exactPC ls

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

instance (ExactP arg) => ExactP (GHC.HsRecField GHC.RdrName (GHC.Located arg)) where
  exactP (GHC.HsRecField n e _) = do
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC e

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

instance ExactP (GHC.HsCmdTop GHC.RdrName) where
  exactP (GHC.HsCmdTop cmd _ _ _) = exactPC cmd

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

instance ExactP (GHC.HsCmd GHC.RdrName) where
  exactP (GHC.HsCmdArrApp e1 e2 _ _ _) = do
    exactPC e1
    -- only one of the next 4 will be resent
    printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<"
    printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-"
    printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<"
    printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-"

    exactPC e2

  exactP (GHC.HsCmdArrForm e _ cs) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) "(|"
    exactPC e
    mapM_ exactPC cs
    printStringAtMaybeAnn (G GHC.AnnClose)  "|)"

  exactP (GHC.HsCmdApp e1 e2) = exactPC e1 >> exactPC e2

  exactP (GHC.HsCmdLam match) = do
    printStringAtMaybeAnn (G GHC.AnnLam) "\\"
    exactPMatchGroup match

  exactP (GHC.HsCmdPar e) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP)  "("
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

  exactP (GHC.HsCmdCase e1 matches) = do
    printStringAtMaybeAnn (G GHC.AnnCase) "case"
    exactPC e1
    printStringAtMaybeAnn (G GHC.AnnOf) "of"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    exactPMatchGroup matches
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.HsCmdIf _ e1 e2 e3)   = do
    printStringAtMaybeAnn (G GHC.AnnIf) "if"
    exactPC e1
    printStringAtMaybeAnn (G GHC.AnnSemi) ";"
    printStringAtMaybeAnn (G GHC.AnnThen) "then"
    exactPC e2
    printStringAtMaybeAnn (G GHC.AnnSemi) ";"
    printStringAtMaybeAnn (G GHC.AnnElse) "else"
    exactPC e3

  exactP (GHC.HsCmdLet lb e)    = do
    printStringAtMaybeAnn (G GHC.AnnLet) "let"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    -- exactP lb
    exactPC (GHC.L (getLocalBindsSrcSpan lb) lb)
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
    printStringAtMaybeAnn (G GHC.AnnIn) "in"
    exactPC e

  exactP (GHC.HsCmdDo stmts _typ)    = do
    printStringAtMaybeAnn (G GHC.AnnDo) "do"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    -- mapM_ exactPC stmts
    ss <- getStoredListSrcSpan
    exactPC (GHC.L ss stmts)
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

  exactP (GHC.HsCmdCast {}) = error $ "exactP.HsCmdCast: only valid after type checker"

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

instance ExactP [GHC.CmdLStmt GHC.RdrName] where
  exactP ls = mapM_ exactPC ls

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

instance ExactP GHC.RdrName where
  exactP n = do
    case rdrName2String n of
      "[]" -> do
        printStringAtMaybeAnn (G GHC.AnnOpenS) "["
        printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
      "()" -> do
        printStringAtMaybeAnn (G GHC.AnnOpenP) "("
        printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
      "(##)" -> do
        printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
        printStringAtMaybeAnn (G GHC.AnnClose) "#)"
      "[::]" -> do
        printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
        printStringAtMaybeAnn (G GHC.AnnClose) ":]"
      str ->  do
        printStringAtMaybeAnn (G GHC.AnnType)      "type"
        printStringAtMaybeAnn (G GHC.AnnOpenP)     "("
        printStringAtMaybeAnn (G GHC.AnnBackquote)  "`"
        printStringAtMaybeAnn (G GHC.AnnTildehsh)  "~#"
        printStringAtMaybeAnn (G GHC.AnnTilde)     "~"
        printStringAtMaybeAnn (G GHC.AnnRarrow)    "->"
        printStringAtMaybeAnn (G GHC.AnnVal)       str
        printStringAtMaybeAnn (G GHC.AnnBackquote) "`"
        printStringAtMaybeAnnAll (G GHC.AnnCommaTuple) "," -- For '(,,,)'
        printStringAtMaybeAnn (G GHC.AnnCloseP)    ")"
        return () `debug` ("exactP.RdrName:n=" ++ str)

instance ExactP GHC.HsIPName where
  exactP (GHC.HsIPName n) = do
    printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS n)

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

exactPMatchGroup :: (ExactP body) => (GHC.MatchGroup GHC.RdrName (GHC.Located body))
                   -> EP ()
exactPMatchGroup (GHC.MG matches _ _ _) = do
  ss <- getStoredListSrcSpan
  exactPC (GHC.L ss matches)

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

instance ExactP body => (ExactP [GHC.LMatch GHC.RdrName (GHC.Located body)]) where
  exactP ls = mapM_ exactPC ls

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

instance ExactP (GHC.HsTupArg GHC.RdrName) where
  exactP (GHC.Missing _) = do
    printStringAtMaybeAnn (G GHC.AnnComma) ","
    return ()
  exactP (GHC.Present e) = do
    exactPC e
    printStringAtMaybeAnn (G GHC.AnnComma) ","

instance ExactP (GHC.HsLocalBinds GHC.RdrName) where
  exactP (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do
    printMerged (GHC.bagToList binds) sigs
  exactP (GHC.HsValBinds (GHC.ValBindsOut _binds _sigs)) = printString "ValBindsOut"
  exactP (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ exactPC binds
  exactP (GHC.EmptyLocalBinds) = return ()

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

instance ExactP (GHC.Sig GHC.RdrName) where
  exactP (GHC.TypeSig lns typ _) = do
    mapM_ exactPC lns
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

  exactP (GHC.PatSynSig n (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do
    printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"

    -- Note: The 'forall' bndrs '.' may occur multiple times
    printStringAtMaybeAnn (G GHC.AnnForall) "forall"
    mapM_ exactPC bndrs
    printStringAtMaybeAnn (G GHC.AnnDot) "."

    exactPC ctx1
    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
    exactPC ctx2
    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
    exactPC typ

  exactP (GHC.GenericSig ns typ) = do
    printStringAtMaybeAnn (G GHC.AnnDefault) "default"
    mapM_ exactPC ns
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC typ

  exactP (GHC.IdSig _) = return ()

  exactP (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do
    let fixstr = case fdir of
         GHC.InfixL -> "infixl"
         GHC.InfixR -> "infixr"
         GHC.InfixN -> "infix"
    printStringAtMaybeAnn (G GHC.AnnInfix) fixstr
    printStringAtMaybeAnn (G GHC.AnnVal) (show v)
    mapM_ exactPC lns

  exactP (GHC.InlineSig n inl) = do
    let actStr = case GHC.inl_act inl of
          GHC.NeverActive -> ""
          GHC.AlwaysActive -> ""
          GHC.ActiveBefore np -> show np
          GHC.ActiveAfter  np -> show np
    printStringAtMaybeAnn (G GHC.AnnOpen) (GHC.inl_src inl) -- "{-# INLINE"
    printStringAtMaybeAnn (G GHC.AnnOpenS)  "["
    printStringAtMaybeAnn (G GHC.AnnTilde) "~"
    printStringAtMaybeAnn (G GHC.AnnVal)   actStr
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"


  exactP (GHC.SpecSig n typs inl) = do
    printStringAtMaybeAnn (G GHC.AnnOpen)  (GHC.inl_src inl) -- "{-# SPECIALISE"
    printStringAtMaybeAnn (G GHC.AnnOpenS)  "["
    printStringAtMaybeAnn (G GHC.AnnTilde)  "~"
    printStringAtMaybeAnn (G GHC.AnnVal)   "TODO:what here?" -- e.g. 34
    printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    mapM_ exactPC typs
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"


  exactP _ = printString "Sig"

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

instance ExactP (GHC.HsOverLit GHC.RdrName) where
  exactP ol = do
    case GHC.ol_val ol of
      GHC.HsIntegral src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src
      GHC.HsFractional l   -> printStringAtMaybeAnn (G GHC.AnnVal) (GHC.fl_text l)
      GHC.HsIsString src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src

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

instance ExactP GHC.HsLit where
  exactP lit = printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lit)

hsLit2String :: GHC.HsLit -> GHC.SourceText
hsLit2String lit =
  case lit of
    GHC.HsChar       src _   -> src
    GHC.HsCharPrim   src _   -> src
    GHC.HsString     src _   -> src
    GHC.HsStringPrim src _   -> src
    GHC.HsInt        src _   -> src
    GHC.HsIntPrim    src _   -> src
    GHC.HsWordPrim   src _   -> src
    GHC.HsInt64Prim  src _   -> src
    GHC.HsWord64Prim src _   -> src
    GHC.HsInteger    src _ _ -> src
    GHC.HsRat        (GHC.FL src _) _ -> src
    GHC.HsFloatPrim  (GHC.FL src _)   -> src
    GHC.HsDoublePrim (GHC.FL src _)   -> src

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


instance ExactP (GHC.TyClDecl GHC.RdrName) where
  exactP (GHC.FamDecl famdecl) = exactP famdecl

  exactP (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do
    printStringAtMaybeAnn (G GHC.AnnType) "type"
    exactPC ln
    mapM_ exactPC tyvars
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC typ

  exactP (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)
           (GHC.HsDataDefn _nOrD ctx mctyp mkind cons mderivs) _) = do
    printStringAtMaybeAnn (G GHC.AnnData)    "data"
    printStringAtMaybeAnn (G GHC.AnnNewtype) "newtype"
    doMaybe exactPC mctyp
    exactPC ctx
    printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
    printTyClass ln tyVars
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    doMaybe exactPC mkind
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    mapM_ exactPC cons
    doMaybe exactPC mderivs

  exactP (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds
                          sigs meths ats atdefs docs _) = do
    printStringAtMaybeAnn (G GHC.AnnClass) "class"
    exactPC ctx
    printTyClass ln tyVars
    printStringAtMaybeAnn (G GHC.AnnVbar) "|"
    mapM_ exactPC fds
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC)  "{"
    printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"

    applyListPrint (prepareListPrint sigs
                 ++ prepareListPrint (GHC.bagToList meths)
                 ++ prepareListPrint ats
                 ++ prepareListPrint atdefs
                 ++ prepareListPrint docs
                    )

    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

printTyClass :: (ExactP ast, ExactP ast1)
             => GHC.Located ast -> [GHC.Located ast1] -> EP ()
printTyClass ln tyVars = do
    printStringAtMaybeAnnAll (G GHC.AnnOpenP) "("
    applyListPrint (prepareListPrint [ln]
               ++ prepareListPrint (take 2 tyVars))
    -- exactPC ln
    printStringAtMaybeAnnAll (G GHC.AnnCloseP) ")"
    mapM_ exactPC (drop 2 tyVars)

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

instance ExactP (GHC.FamilyDecl GHC.RdrName) where
  exactP (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do
    printStringAtMaybeAnn (G GHC.AnnType)   "type"
    printStringAtMaybeAnn (G GHC.AnnData)   "data"
    printStringAtMaybeAnn (G GHC.AnnFamily) "family"
    exactPC ln
    mapM_ exactPC tyvars
    case mkind of
      Nothing -> return ()
      Just k -> exactPC k
    printStringAtMaybeAnn (G GHC.AnnWhere) "where"
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    case info of
      GHC.ClosedTypeFamily eqns -> mapM_ exactPC eqns
      _ -> return ()
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

instance ExactP (GHC.TyFamDefltEqn GHC.RdrName) where
   exactP = assert False undefined

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

instance ExactP (GHC.TyFamInstEqn GHC.RdrName) where
  exactP (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do
    exactPC ln
    mapM_ exactPC pats
    printStringAtMaybeAnn (G GHC.AnnEqual) "="
    exactPC typ

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

instance ExactP GHC.DocDecl where
  exactP (GHC.DocCommentNext (GHC.HsDocString fs))
    = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
  exactP (GHC.DocCommentPrev (GHC.HsDocString fs))
    = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
  exactP (GHC.DocCommentNamed _s (GHC.HsDocString fs))
    = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
  exactP (GHC.DocGroup _i (GHC.HsDocString fs))
    = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)

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

instance ExactP (GHC.FunDep (GHC.Located GHC.RdrName)) where
  exactP (ls,rs) = do
    mapM_ exactPC ls
    printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
    mapM_ exactPC rs

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

instance ExactP (GHC.HsTyVarBndr GHC.RdrName) where
  exactP (GHC.UserTyVar n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)
  exactP (GHC.KindedTyVar n ty) = do
    printStringAtMaybeAnn (G GHC.AnnOpenP) "("
    exactPC n
    printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
    exactPC ty
    printStringAtMaybeAnn (G GHC.AnnCloseP) ")"

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

instance ExactP [GHC.LConDecl GHC.RdrName] where
  exactP cons = mapM_ exactPC cons

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

instance ExactP (GHC.ConDecl GHC.RdrName) where
  exactP (GHC.ConDecl lns _exp (GHC.HsQTvs _ns bndrs) ctx dets res _ _) = do
    case res of
      GHC.ResTyH98 -> do
        printStringAtMaybeAnn (G GHC.AnnForall) "forall"
        mapM_ exactPC bndrs
        printStringAtMaybeAnn (G GHC.AnnDot) "."

        exactPC ctx
        printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"

        -- only do names if not infix
        case dets of
          GHC.InfixCon _ _ -> return ()
          _ -> mapM_ exactPC lns

        case dets of
          GHC.PrefixCon args -> mapM_ exactPC args
          GHC.RecCon fs -> do
            printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
            exactPC fs
            printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
          GHC.InfixCon a1 a2 -> do
            exactPC a1
            mapM_ exactPC lns
            exactPC a2


      GHC.ResTyGADT ls ty -> do
        -- only do names if not infix
        case dets of
          GHC.InfixCon _ _ -> return ()
          _ -> mapM_ exactPC lns

        case dets of
          GHC.PrefixCon args -> mapM_ exactPC args
          GHC.RecCon fs -> do
            printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
            exactPC fs
            printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
          GHC.InfixCon a1 a2 -> do
            exactPC a1
            mapM_ exactPC lns
            exactPC a2

        printStringAtMaybeAnn (G GHC.AnnDcolon) "::"

        exactPC (GHC.L ls (ResTyGADTHook bndrs))

        exactPC ctx
        printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
        exactPC ty

    printStringAtMaybeAnn (G GHC.AnnVbar) "|"

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

instance ExactP (ResTyGADTHook GHC.RdrName) where
  exactP (ResTyGADTHook bndrs) = do
    printStringAtMaybeAnn (G GHC.AnnForall) "forall"
    mapM_ exactPC bndrs
    printStringAtMaybeAnn (G GHC.AnnDot) "."

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

instance ExactP [GHC.LConDeclField GHC.RdrName] where
  exactP fs = do
    printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
    mapM_ exactPC fs
    printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
    printStringAtMaybeAnn (G GHC.AnnCloseC) "}"

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

instance ExactP (GHC.CType) where
  exactP (GHC.CType src mh f) = do
    printStringAtMaybeAnn (G GHC.AnnOpen) src
    case mh of
      Nothing -> return ()
      Just (GHC.Header h) ->
         printStringAtMaybeAnn (G GHC.AnnHeader) ("\"" ++ GHC.unpackFS h ++ "\"")
    printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ GHC.unpackFS f ++ "\"")
    printStringAtMaybeAnn (G GHC.AnnClose) "#-}"

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