packages feed

ghc-exactprint 0.1.1.0 → 0.2

raw patch · 129 files changed

+7011/−4719 lines, 129 filesdep +freenew-uploader

Dependencies added: free

Files

+ ChangeLog view
@@ -0,0 +1,47 @@+2015-03-24 v0.2+	This release contains a major rewrite of all internal modules.++	The external interface has also changed significantly. A description is+	omitted.++	# Top-level changes+	The most notable change is that the common structor of the modules known as+	`ExactPrint` and `Annotate` has been factored out into a common module+	(`Annotate`). The aforementioned modules are now known as `Delta` and+	`Print` and contain functions to interpret this common structure.++	The top level module `ExactPrint` now just reexports a consistent interface+	from the base modules.++	Introduced a new module `Lookup` which contains a mapping from AnnKeywordId+	to their String representation.++	# Internal Changes++	`Annotate` contains all the information about which annotations appear on+	each AST element. This is achieved by building up a syntax tree (using a+	free monad) which can then be interpreted by programs requiring access to+	this information.++	# Layout compensation++	The method which compensates for layout rules has been clarified.++		1. When the Layout Flag is activated in `Annotate`, we mark+	the current column as the start of the layout block.++		2. This is important when we move to a new line. We take the offset at+		that current point to be the baseline and calculate the correct next+		position based on this.++		3. This method is very general as one can think of a entire source file as+		obeying layout rules where the offset is equal to zero.+++2015-03-11 v0.1.1.0+	Handles indentation when the AST is edited+	Major rework of internal monads by @mpickering+2015-01-28 v0.1.0.1+	Update cabal to prevent building with GHC 7.70,thanks @peti+2015-01-24 v0.1.0.0+	Initial release, for GHC 7.10 RC 2
ghc-exactprint.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                ghc-exactprint-version:             0.1.1.0+version:             0.2 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 7.10 RC2, this                      library provides a means to round trip any* code that can@@ -17,18 +17,30 @@  license:             BSD3 license-file:        LICENSE-author:              Alan Zimmerman, Matt Pickering+author:              Alan Zimmerman, Matthew Pickering maintainer:          alan.zimm@gmail.com -- copyright: category:            Development build-type:          Simple--- extra-source-files:+extra-source-files:  ChangeLog+                     tests/examples/*.hs+                     tests/examples/*.hs.expected+                     tests/examples/*.hs-boot cabal-version:       >=1.10 +source-repository head+  type:     git+  location: https://github.com/alanz/ghc-exactprint.git+ library   exposed-modules:     Language.Haskell.GHC.ExactPrint                      , Language.Haskell.GHC.ExactPrint.Types                      , Language.Haskell.GHC.ExactPrint.Utils+                     , Language.Haskell.GHC.ExactPrint.Delta+                     , Language.Haskell.GHC.ExactPrint.Lookup+                     , Language.Haskell.GHC.ExactPrint.Annotate+                     , Language.Haskell.GHC.ExactPrint.Print+  GHC-Options:         -Wall   -- other-modules:   -- other-extensions:   build-depends:       base >=4.7 && <4.9@@ -40,6 +52,7 @@                      , ghc-syb-utils                      , mtl                      , syb+                     , free   hs-source-dirs:      src   default-language:    Haskell2010   -- Note: the following constraint actually requires RC2 or better@@ -66,8 +79,5 @@                      , stm                      , syb -source-repository head-  type:     git-  location: https://github.com/alanz/ghc-exactprint.git
src/Language/Haskell/GHC/ExactPrint.hs view
@@ -1,2071 +1,14 @@-{-# 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) "#-}"---- -----------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint+        ( -- * Relativising+          relativiseApiAnns+        , Anns++        -- * Printing+        , exactPrintWithAnns+        , exactPrint++        ) where++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Delta+import Language.Haskell.GHC.ExactPrint.Print
+ src/Language/Haskell/GHC/ExactPrint/Annotate.hs view
@@ -0,0 +1,1961 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Language.Haskell.GHC.ExactPrint.Annotate+       (+         markLocated+       , AnnotationF(..)+       , Annotated+       , Annotate(..)) where++import Control.Exception (assert)+import Data.Data (Data)+import Data.List (sort, sortBy)+import Data.Maybe (fromMaybe)+import Control.Monad (when)++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils (rdrName2String, showGhc, isListComp, debug)++import qualified Bag            as GHC+import qualified BasicTypes     as GHC+import qualified BooleanFormula 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 Outputable     as GHC+import qualified SrcLoc         as GHC+++import Control.Monad.Trans.Free+import Control.Monad.Free.TH (makeFreeCon)++-- ---------------------------------------------------------------------+++data AnnotationF next where+  MarkEOF  :: next -> AnnotationF next+  MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next+  MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next+  MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next+  MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next+  MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next+  MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next+  MarkAfter :: GHC.AnnKeywordId -> next -> AnnotationF next+  WithAST  :: Data a => GHC.Located a -> LayoutFlag -> Annotated b ->  next -> AnnotationF next+  CountAnns ::  GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next+  -- Abstraction breakers+  SetLayoutFlag ::  GHC.AnnKeywordId -> Annotated () -> next -> AnnotationF next+  OutputKD :: (DeltaPos, (GHC.SrcSpan, KeywordId)) -> next -> AnnotationF next++deriving instance Functor (AnnotationF)+++type Annotated = Free AnnotationF++-- ---------------------------------------------------------------------++makeFreeCon  'OutputKD+makeFreeCon  'MarkEOF+makeFreeCon  'MarkPrim+makeFreeCon  'MarkOutside+makeFreeCon  'MarkInside+makeFreeCon  'MarkExternal+makeFreeCon  'MarkMany+makeFreeCon  'MarkOffsetPrim+makeFreeCon  'MarkAfter+makeFreeCon  'CountAnns+makeFreeCon  'SetLayoutFlag+-- ---------------------------------------------------------------------+-- Additional smart constructors++mark :: GHC.AnnKeywordId -> Annotated ()+mark kwid = markPrim kwid Nothing++markWithString :: GHC.AnnKeywordId -> String -> Annotated ()+markWithString kwid s = markPrim kwid (Just s)++markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated ()+markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s)++markOffset :: GHC.AnnKeywordId -> Int -> Annotated ()+markOffset kwid n = markOffsetPrim kwid n Nothing++withAST :: Data a => GHC.Located a -> LayoutFlag -> Annotated () -> Annotated ()+withAST lss layout action = liftF (WithAST lss layout prog ())+  where+    prog = do+      action+      -- Automatically add any trailing comma or semi+      markAfter GHC.AnnComma+      markOutside GHC.AnnSemi AnnSemiSep+-- ---------------------------------------------------------------------+++-- | Constructs a syntax tree which contains information about which+-- annotations are required by each element.+markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()+markLocated a = withLocated a NoLayoutRules markAST++withLocated :: Data a+            => GHC.Located a+            -> LayoutFlag+            -> (GHC.SrcSpan -> a -> Annotated ())+            -> Annotated ()+withLocated a@(GHC.L l ast) layoutFlag action =+  withAST a layoutFlag (action l ast)++markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()+markMaybe Nothing    = return ()+markMaybe (Just ast) = markLocated ast++markList :: (Annotate ast) => [GHC.Located ast] -> Annotated ()+markList xs = mapM_ markLocated xs++-- | Flag the item to be annotated as requiring layout.+markWithLayout :: Annotate ast => GHC.Located ast -> Annotated ()+markWithLayout a = withLocated a LayoutRules markAST++markListWithLayout :: Annotate [GHC.Located ast] => GHC.SrcSpan -> [GHC.Located ast] -> Annotated ()+markListWithLayout l ls = do+  let ss = getListSrcSpan ls+  outputKD $ ((DP (0,0)), (l,AnnList ss))+  markWithLayout (GHC.L ss ls)++-- ---------------------------------------------------------------------+-- Managing lists which have been separated, e.g. Sigs and Binds++prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]+prepareListAnnotation ls = map (\b@(GHC.L l _) -> (l,markLocated b)) ls++applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated ()+applyListAnnotations ls+  = mapM_ snd $ sortBy (\(a,_) (b,_) -> compare a b) ls++-- ---------------------------------------------------------------------++class Data ast => Annotate ast where+  markAST :: GHC.SrcSpan -> ast -> Annotated ()++-- ---------------------------------------------------------------------++instance Annotate (GHC.HsModule GHC.RdrName) where+  markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do+++    case mmn of+      Nothing -> return ()+      Just (GHC.L ln mn) -> do+        mark GHC.AnnModule+        markExternal ln GHC.AnnVal (GHC.moduleNameString mn)++    case mdepr of+      Nothing -> return ()+      Just depr -> markLocated depr++    case mexp of+      Nothing   -> return ()+      Just expr -> markLocated expr++    mark GHC.AnnWhere+    mark GHC.AnnOpenC -- Possible '{'+    markMany GHC.AnnSemi -- possible leading semis+    mapM_ markLocated imps++    markList decs++    mark GHC.AnnCloseC -- Possible '}'++    markEOF++-- ---------------------------------------------------------------------++instance Annotate GHC.WarningTxt where+  markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do+    markExternal ls GHC.AnnOpen txt+    mark GHC.AnnOpenS+    mapM_ markLocated lss+    mark GHC.AnnCloseS+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do+    markExternal ls GHC.AnnOpen txt+    mark GHC.AnnOpenS+    mapM_ markLocated lss+    mark GHC.AnnCloseS+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name)+  => Annotate [GHC.LIE name] where+   markAST _ ls = do+     mark GHC.AnnHiding -- in an import decl+     mark GHC.AnnOpenP -- '('+     mapM_ markLocated ls+     mark GHC.AnnCloseP -- ')'++instance (GHC.DataId name,Annotate name)+  => Annotate (GHC.IE name) where+  markAST _ ie = do++    case ie of+        (GHC.IEVar ln) -> do+          mark GHC.AnnPattern+          mark GHC.AnnType+          markLocated ln++        (GHC.IEThingAbs ln) -> do+          mark GHC.AnnType+          markLocated ln++        (GHC.IEThingWith ln ns) -> do+          markLocated ln+          mark GHC.AnnOpenP+          mapM_ markLocated ns+          mark GHC.AnnCloseP++        (GHC.IEThingAll ln) -> do+          markLocated ln+          mark GHC.AnnOpenP+          mark GHC.AnnDotdot+          mark GHC.AnnCloseP++        (GHC.IEModuleContents (GHC.L lm mn)) -> do+          mark GHC.AnnModule+          markExternal lm GHC.AnnVal (GHC.moduleNameString mn)++        -- Only used in Haddock mode so we can ignore them.+        (GHC.IEGroup _ _) -> return ()++        (GHC.IEDoc _)     -> return ()++        (GHC.IEDocNamed _)    -> return ()++-- ---------------------------------------------------------------------++instance Annotate GHC.RdrName where+  markAST l n = do+    case rdrName2String n of+      "[]" -> do+        mark GHC.AnnOpenS  -- '['+        mark GHC.AnnCloseS -- ']'+      "()" -> do+        mark GHC.AnnOpenP  -- '('+        mark GHC.AnnCloseP -- ')'+      "(##)" -> do+        markWithString GHC.AnnOpen  "(#" -- '(#'+        markWithString GHC.AnnClose  "#)"-- '#)'+      "[::]" -> do+        markWithString GHC.AnnOpen  "[:" -- '[:'+        markWithString GHC.AnnClose ":]" -- ':]'+      str ->  do+        mark GHC.AnnType+        mark GHC.AnnOpenP -- '('+        markOffset GHC.AnnBackquote 0+        markMany GHC.AnnCommaTuple -- For '(,,,)'+        cnt <- countAnns GHC.AnnVal+        cntT <- countAnns GHC.AnnCommaTuple+        cntR <- countAnns GHC.AnnRarrow+        case cnt of+          0 -> if cntT >0 || cntR >0+                 then return ()+                 else markExternal l GHC.AnnVal str+          1 -> markWithString GHC.AnnVal str+          x -> error $ "markP.RdrName: too many AnnVal :" ++ showGhc (l,x)+        mark GHC.AnnTildehsh+        mark GHC.AnnTilde+        mark GHC.AnnRarrow+        markOffset GHC.AnnBackquote 1+        mark GHC.AnnCloseP -- ')'++-- ---------------------------------------------------------------------++-- TODO: What is this used for? Not in ExactPrint+instance Annotate GHC.Name where+  markAST l n = do+    markExternal l GHC.AnnVal (showGhc n)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name)+  => Annotate (GHC.ImportDecl name) where+ markAST _ imp@(GHC.ImportDecl msrc (GHC.L ln _) _pkg src safeflag _qual _impl _as hiding) = do++   -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec+   mark GHC.AnnImport++   -- "{-# SOURCE" and "#-}"+   when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc)+             >> markWithString GHC.AnnClose "#-}")+   when safeflag (mark GHC.AnnSafe)+   mark GHC.AnnQualified+   mark GHC.AnnPackageName++   markExternal ln GHC.AnnVal (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp)++   case GHC.ideclAs imp of+      Nothing -> return ()+      Just mn -> do+          mark GHC.AnnAs+          markWithString GHC.AnnVal (GHC.moduleNameString mn)++   case hiding of+     Nothing -> return ()+     Just (_isHiding,lie) -> do+       mark GHC.AnnHiding+       markLocated lie++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.HsDecl name) where+  markAST l decl = do+    case decl of+      GHC.TyClD d       -> markAST l d+      GHC.InstD d       -> markAST l d+      GHC.DerivD d      -> markAST l d+      GHC.ValD d        -> markAST l d+      GHC.SigD d        -> markAST l d+      GHC.DefD d        -> markAST l d+      GHC.ForD d        -> markAST l d+      GHC.WarningD d    -> markAST l d+      GHC.AnnD d        -> markAST l d+      GHC.RuleD d       -> markAST l d+      GHC.VectD d       -> markAST l d+      GHC.SpliceD d     -> markAST l d+      GHC.DocD d        -> markAST l d+      GHC.QuasiQuoteD d -> markAST l d+      GHC.RoleAnnotD d  -> markAST l d++-- ---------------------------------------------------------------------++instance (Annotate name)+   => Annotate (GHC.RoleAnnotDecl name) where+  markAST _ (GHC.RoleAnnotDecl ln mr) = do+    mark GHC.AnnType+    mark GHC.AnnRole+    markLocated ln+    mapM_ markLocated mr++instance Annotate (Maybe GHC.Role) where+  markAST l Nothing  = markExternal l GHC.AnnVal "_"+  markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r)++-- ---------------------------------------------------------------------++instance (Annotate name)+   => Annotate (GHC.HsQuasiQuote name) where+  markAST _ (GHC.HsQuasiQuote _n _ss _fs) = assert False undefined++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.SpliceDecl name) where+  markAST _ (GHC.SpliceDecl (GHC.L _ (GHC.HsSplice _n e)) flag) = do+    case flag of+      GHC.ExplicitSplice ->+        markWithString GHC.AnnOpen "$("+      GHC.ImplicitSplice ->+        markWithString GHC.AnnOpen "$$("+    markLocated e+    markWithString GHC.AnnClose ")"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.VectDecl name) where+  markAST _ (GHC.HsVect src ln e) = do+    markWithString GHC.AnnOpen src -- "{-# VECTORISE"+    markLocated ln+    mark GHC.AnnEqual+    markLocated e+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsNoVect src ln) = do+    markWithString GHC.AnnOpen src -- "{-# NOVECTORISE"+    markLocated ln+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsVectTypeIn src _b ln mln) = do+    markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR"+    mark GHC.AnnType+    markLocated ln+    mark GHC.AnnEqual+    markMaybe mln+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsVectTypeOut {}) = error $ "markP.HsVectTypeOut: only valid after type checker"++  markAST _ (GHC.HsVectClassIn src ln) = do+    markWithString GHC.AnnOpen src -- "{-# VECTORISE"+    mark GHC.AnnClass+    markLocated ln+    markWithString GHC.AnnClose "#-}" -- "#-}"++  markAST _ (GHC.HsVectClassOut {}) = error $ "markP.HsVectClassOut: only valid after type checker"+  markAST _ (GHC.HsVectInstIn {})   = error $ "markP.HsVectInstIn: not supported?"+  markAST _ (GHC.HsVectInstOut {})   = error $ "markP.HsVectInstOut: not supported?"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.RuleDecls name) where+   markAST _ (GHC.HsRules src rules) = do+     markWithString GHC.AnnOpen src+     mapM_ markLocated rules+     markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.RuleDecl name) where+  markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do+    markLocated ln+    -- activation+    mark GHC.AnnOpenS -- "["+    mark GHC.AnnTilde+    case act of+      GHC.ActiveBefore n -> markWithString GHC.AnnVal (show n)+      GHC.ActiveAfter n  -> markWithString GHC.AnnVal (show n)+      _                  -> return ()+    mark GHC.AnnCloseS -- "]"++    mark GHC.AnnForall+    mapM_ markLocated bndrs+    mark GHC.AnnDot++    markLocated lhs+    mark GHC.AnnEqual+    markLocated rhs++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.RuleBndr name) where+  markAST _ (GHC.RuleBndr ln) = markLocated ln+  markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do+    mark GHC.AnnOpenP -- "("+    markLocated ln+    mark GHC.AnnDcolon+    markLocated thing+    mark GHC.AnnCloseP -- ")"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.AnnDecl name) where+   markAST _ (GHC.HsAnnotation src prov e) = do+     markWithString GHC.AnnOpen src+     mark GHC.AnnType+     mark GHC.AnnModule+     case prov of+       (GHC.ValueAnnProvenance n) -> markLocated n+       (GHC.TypeAnnProvenance n) -> markLocated n+       (GHC.ModuleAnnProvenance) -> return ()++     markLocated e+     markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance Annotate name => Annotate (GHC.WarnDecls name) where+   markAST _ (GHC.Warnings src warns) = do+     markWithString GHC.AnnOpen src+     mapM_ markLocated warns+     markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance (Annotate name)+   => Annotate (GHC.WarnDecl name) where+   markAST _ (GHC.Warning lns txt) = do+     mapM_ markLocated lns+     mark GHC.AnnOpenS -- "["+     case txt of+       GHC.WarningTxt    _src ls -> mapM_ markLocated ls+       GHC.DeprecatedTxt _src ls -> mapM_ markLocated ls+     mark GHC.AnnCloseS -- "]"++instance Annotate GHC.FastString where+  markAST l fs = markExternal l GHC.AnnVal (show (GHC.unpackFS fs))++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.ForeignDecl name) where++  markAST _ (GHC.ForeignImport ln typ _+               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do+    mark GHC.AnnForeign+    mark GHC.AnnImport+    markLocated cconv+    if ll == GHC.noSrcSpan+      then return ()+      else markLocated safety+    -- markMaybe mh+    markExternal ls GHC.AnnVal ("\"" ++ src ++ "\"")+    markLocated ln+    mark GHC.AnnDcolon+    markLocated typ+++  markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do+    mark GHC.AnnForeign+    mark GHC.AnnExport+    markLocated spec+    markExternal ls GHC.AnnVal ("\"" ++ src ++ "\"")+    markLocated ln+    mark GHC.AnnDcolon+    markLocated typ+++-- ---------------------------------------------------------------------++instance (Annotate GHC.CExportSpec) where+  markAST l (GHC.CExportStatic _ cconv) = markAST l cconv++-- ---------------------------------------------------------------------++instance (Annotate GHC.CCallConv) where+  markAST l GHC.StdCallConv        =  markExternal l  GHC.AnnVal "stdcall"+  markAST l GHC.CCallConv          =  markExternal l GHC.AnnVal "ccall"+  markAST l GHC.CApiConv           =  markExternal l GHC.AnnVal "capi"+  markAST l GHC.PrimCallConv       =  markExternal l GHC.AnnVal "prim"+  markAST l GHC.JavaScriptCallConv =  markExternal l GHC.AnnVal "javascript"++-- ---------------------------------------------------------------------++instance (Annotate GHC.Safety) where+  markAST l GHC.PlayRisky         = markExternal l GHC.AnnVal "unsafe"+  markAST l GHC.PlaySafe          = markExternal l GHC.AnnVal "safe"+  markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.DerivDecl name) where++  markAST _ (GHC.DerivDecl typ mov) = do+    mark GHC.AnnDeriving+    mark GHC.AnnInstance+    markMaybe mov+    markLocated typ++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.DefaultDecl name) where++  markAST _ (GHC.DefaultDecl typs) = do+    mark GHC.AnnDefault+    mark GHC.AnnOpenP -- '('+    mapM_ markLocated typs+    mark GHC.AnnCloseP -- ')'++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.InstDecl name) where++  markAST l (GHC.ClsInstD      cid) = markAST l  cid+  markAST l (GHC.DataFamInstD dfid) = markAST l dfid+  markAST l (GHC.TyFamInstD   tfid) = markAST l tfid++-- ---------------------------------------------------------------------++instance Annotate GHC.OverlapMode where+  markAST _ (GHC.NoOverlap src) = do+    markWithString GHC.AnnOpen src+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlappable src) = do+    markWithString GHC.AnnOpen src+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlapping src) = do+    markWithString GHC.AnnOpen src+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Overlaps src) = do+    markWithString GHC.AnnOpen src+    markWithString GHC.AnnClose "#-}"++  markAST _ (GHC.Incoherent src) = do+    markWithString GHC.AnnOpen src+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.ClsInstDecl name) where++  markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do+    mark GHC.AnnInstance+    markMaybe mov+    markLocated poly+    mark GHC.AnnWhere+    mark GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi++    -- AZ:Need to turn this into a located list annotation.+    -- must merge all the rest+    applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)+                       ++ prepareListAnnotation sigs+                       ++ prepareListAnnotation tyfams+                       ++ prepareListAnnotation datafams+                         )++    mark GHC.AnnCloseC -- '}'++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.TyFamInstDecl name) where++  markAST _ (GHC.TyFamInstDecl eqn _) = do+    mark GHC.AnnType+    mark GHC.AnnInstance+    markLocated eqn++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.DataFamInstDecl name) where++  markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do+    mark GHC.AnnData+    mark GHC.AnnNewtype+    mark GHC.AnnInstance+    markLocated ln+    mapM_ markLocated pats+    mark GHC.AnnWhere+    mark GHC.AnnEqual+    markDataDefn l defn++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>+                                                  Annotate (GHC.HsBind name) where+  markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do+    mapM_ markLocated matches+    -- markMatchGroup l mg++  markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do+    markLocated lhs+    mark GHC.AnnEqual+    mapM_ markLocated grhs+    mark GHC.AnnWhere++    -- TODO: Store the following SrcSpan in an AnnList instance for exactPC+    markLocated (GHC.L (getLocalBindsSrcSpan lb) lb)++  markAST _ (GHC.VarBind _n rhse _) =+    -- Note: this bind is introduced by the typechecker+    markLocated rhse++  markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do+    mark GHC.AnnPattern+    markLocated ln+    case args of+      GHC.InfixPatSyn la lb -> do+        markLocated la+        markLocated lb+      GHC.PrefixPatSyn ns -> do+        mapM_ markLocated ns+    mark GHC.AnnEqual+    mark GHC.AnnLarrow+    markLocated def+    case dir of+      GHC.Unidirectional           -> return ()+      GHC.ImplicitBidirectional    -> return ()+      GHC.ExplicitBidirectional mg -> markMatchGroup l mg++    mark GHC.AnnWhere+    mark GHC.AnnOpenC  -- '{'+    mark GHC.AnnCloseC -- '}'++  -- Introduced after renaming.+  markAST _ (GHC.AbsBinds _ _ _ _ _) = return ()+++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+    => Annotate (GHC.IPBind name) where+  markAST _ (GHC.IPBind en e) = do+    case en of+      Left n -> markLocated n+      Right _i -> error $ "markP.IPBind:should not happen"+    mark GHC.AnnEqual+    markLocated e++-- ---------------------------------------------------------------------++instance Annotate GHC.HsIPName where+  markAST l (GHC.HsIPName n) = markExternal l (GHC.AnnVal) ("?" ++ GHC.unpackFS n)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,+                                                  Annotate body)+  => Annotate (GHC.Match name (GHC.Located body)) where++  markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do+    let+      get_infix Nothing = False+      get_infix (Just (_,f)) = f+    case (get_infix mln,pats) of+      (True,[a,b]) -> do+        markLocated a+        case mln of+          Nothing -> do+            markWithString GHC.AnnOpen "`" -- possible '`'+            mark GHC.AnnFunId+            markWithString GHC.AnnClose "`"-- possible '`'+          Just (n,_) -> markLocated n+        markLocated b+      _ -> do+        case mln of+          Nothing -> mark GHC.AnnFunId+          Just (n,_) -> markLocated n+        mapM_ markLocated pats++    mark GHC.AnnEqual+    mark GHC.AnnRarrow -- For HsLam++    mapM_ markLocated grhs++    mark GHC.AnnWhere+    mark GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi+    markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)+    mark GHC.AnnCloseC -- '}'++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,+                                                  Annotate body)+  => Annotate (GHC.GRHS name (GHC.Located body)) where+  markAST _ (GHC.GRHS guards expr) = do++    mark GHC.AnnVbar+    mapM_ markLocated guards+    mark GHC.AnnEqual+    mark GHC.AnnRarrow -- in case alts+    markLocated expr++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.Sig name) where++  markAST _ (GHC.TypeSig lns typ _) = do+    mapM_ markLocated lns+    mark GHC.AnnDcolon+    markLocated typ++  markAST _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do+    mark GHC.AnnPattern+    markLocated ln+    mark GHC.AnnDcolon++    -- Note: The 'forall' bndrs '.' may occur multiple times+    mark GHC.AnnForall+    mapM_ markLocated bndrs+    mark GHC.AnnDot++    markLocated ctx1+    markOffset GHC.AnnDarrow 0+    markLocated ctx2+    markOffset GHC.AnnDarrow 1+    markLocated typ+++  markAST _ (GHC.GenericSig ns typ) = do+    mark GHC.AnnDefault+    mapM_ markLocated ns+    mark GHC.AnnDcolon+    markLocated typ++  markAST _ (GHC.IdSig _) = return ()++  -- FixSig (FixitySig name)+  markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do+    let fixstr = case fdir of+         GHC.InfixL -> "infixl"+         GHC.InfixR -> "infixr"+         GHC.InfixN -> "infix"+    markWithString GHC.AnnInfix fixstr+    markWithString GHC.AnnVal (show v)+    mapM_ markLocated lns++  -- InlineSig (Located name) InlinePragma+  -- '{-# INLINE' activation qvar '#-}'+  markAST _ (GHC.InlineSig ln inl) = do+    let actStr = case GHC.inl_act inl of+          GHC.NeverActive -> ""+          GHC.AlwaysActive -> ""+          GHC.ActiveBefore np -> show np+          GHC.ActiveAfter  np -> show np+    markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE'+    mark GHC.AnnOpenS  -- '['+    mark  GHC.AnnTilde -- ~+    markWithString  GHC.AnnVal actStr -- e.g. 34+    mark GHC.AnnCloseS -- ']'+    markLocated ln+    markWithString GHC.AnnClose "#-}" -- '#-}'+++  markAST _ (GHC.SpecSig ln typs inl) = do+    markWithString GHC.AnnOpen (GHC.inl_src inl)+    mark GHC.AnnOpenS --  '['+    mark GHC.AnnTilde -- ~+    markWithString GHC.AnnVal  "TODO: What here"++    mark GHC.AnnCloseS -- ']'+    markLocated ln+    mark GHC.AnnDcolon -- '::'+    mapM_ markLocated typs+    markWithString GHC.AnnClose "#-}" -- '#-}'+++  -- '{-# SPECIALISE' 'instance' inst_type '#-}'+  markAST _ (GHC.SpecInstSig src typ) = do+    markWithString GHC.AnnOpen src+    mark GHC.AnnInstance+    markLocated typ+    markWithString GHC.AnnClose "#-}" -- '#-}'+++  -- MinimalSig (BooleanFormula (Located name))+  markAST _ (GHC.MinimalSig src  formula) = do+    markWithString GHC.AnnOpen src+    markBooleanFormula formula+    markWithString GHC.AnnClose "#-}"+++-- ---------------------------------------------------------------------++markBooleanFormula :: GHC.BooleanFormula (GHC.Located name) -> Annotated ()+markBooleanFormula = assert False undefined++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>+                     Annotate (GHC.HsTyVarBndr name) where+  markAST l (GHC.UserTyVar n) = do+    markAST l n++  markAST _ (GHC.KindedTyVar n ty) = do+    mark GHC.AnnOpenP  -- '('+    markLocated n+    mark GHC.AnnDcolon -- '::'+    markLocated ty+    mark GHC.AnnCloseP -- '('++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.HsType name) where++  markAST _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do+    mark GHC.AnnOpenP -- "("+    mark GHC.AnnForall+    mapM_ markLocated tvs+    mark GHC.AnnDot++    case mwc of+      Nothing -> if lc /= GHC.noSrcSpan then markLocated ctx else return ()+      Just lwc -> markLocated (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs)))++    mark GHC.AnnDarrow+    markLocated typ+    mark GHC.AnnCloseP -- ")"++  markAST l (GHC.HsTyVar n) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    markAST l n++  markAST _ (GHC.HsAppTy t1 t2) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    markLocated t1+    markLocated t2++  markAST _ (GHC.HsFunTy t1 t2) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    markLocated t1+    mark GHC.AnnRarrow+    markLocated t2++  markAST _ (GHC.HsListTy t) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    mark GHC.AnnOpenS -- '['+    markLocated t+    mark GHC.AnnCloseS -- ']'++  markAST _ (GHC.HsPArrTy t) = do+    markWithString GHC.AnnOpen "[:" -- '[:'+    markLocated t+    markWithString GHC.AnnClose ":]" -- ':]'++  markAST _ (GHC.HsTupleTy _tt ts) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    markWithString GHC.AnnOpen "(#" -- '(#'+    mark GHC.AnnOpenP  -- '('+    mapM_ markLocated ts+    mark GHC.AnnCloseP -- ')'+    markWithString GHC.AnnClose "#)" --  '#)'++  markAST _ (GHC.HsOpTy t1 (_,lo) t2) = do+    markLocated t1+    markLocated lo+    markLocated t2++  markAST _ (GHC.HsParTy t) = do+    mark GHC.AnnDcolon -- for HsKind, alias for HsType+    mark GHC.AnnOpenP  -- '('+    markLocated t+    mark GHC.AnnCloseP -- ')'++  markAST _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do+    markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n))+    mark GHC.AnnDcolon+    markLocated t++  markAST _ (GHC.HsEqTy t1 t2) = do+    markLocated t1+    mark GHC.AnnTilde+    markLocated t2++  markAST _ (GHC.HsKindSig t k) = do+    mark GHC.AnnOpenP  -- '('+    markLocated t+    mark GHC.AnnDcolon -- '::'+    markLocated k+    mark GHC.AnnCloseP -- ')'++  -- HsQuasiQuoteTy (HsQuasiQuote name)+  -- TODO: Probably wrong+  markAST l (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote n _ss q)) = do+    markExternal l GHC.AnnVal+      ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")++  -- HsSpliceTy (HsSplice name) (PostTc name Kind)+  markAST _ (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do+    markWithString GHC.AnnOpen "$(" -- '$('+    markLocated e+    markWithString GHC.AnnClose ")" -- ')'++  markAST _ (GHC.HsDocTy t ds) = do+    markLocated t+    markLocated ds++  markAST _ (GHC.HsBangTy b t) = do+    case b of+      (GHC.HsSrcBang ms (Just True) _) -> do+        markWithString GHC.AnnOpen  (maybe "{-# UNPACK" id ms)+        markWithString GHC.AnnClose "#-}"+      (GHC.HsSrcBang ms (Just False) _) -> do+        markWithString GHC.AnnOpen  (maybe "{-# NOUNPACK" id ms)+        markWithString GHC.AnnClose "#-}"+      _ -> return ()+    mark GHC.AnnBang+    markLocated t++  -- HsRecTy [LConDeclField name]+  markAST _ (GHC.HsRecTy cons) = do+    mark GHC.AnnOpenC  -- '{'+    mapM_ markLocated cons+    mark GHC.AnnCloseC -- '}'++  -- HsCoreTy Type+  markAST _ (GHC.HsCoreTy _t) = return ()++  markAST _ (GHC.HsExplicitListTy _ ts) = do+    -- TODO: what about SIMPLEQUOTE?+    markWithString GHC.AnnOpen "'[" -- "'["+    mapM_ markLocated ts+    mark GHC.AnnCloseS -- ']'++  markAST _ (GHC.HsExplicitTupleTy _ ts) = do+    markWithString GHC.AnnOpen "'(" -- "'("+    mapM_ markLocated ts+    markWithString GHC.AnnClose ")" -- ')'++  -- HsTyLit HsTyLit+  markAST l (GHC.HsTyLit lit) = do+    case lit of+      (GHC.HsNumTy s _) ->+        markExternal l GHC.AnnVal s+      (GHC.HsStrTy s _) ->+        markExternal l GHC.AnnVal s++  -- HsWrapTy HsTyAnnotated (HsType name)+  markAST _ (GHC.HsWrapTy _ _) = return ()++  markAST l (GHC.HsWildcardTy) = do+    markExternal l GHC.AnnVal "_"+    mark GHC.AnnDarrow -- if only part of a partial type signature context+-- TODO: Probably wrong+  markAST l (GHC.HsNamedWildcardTy n) = do+    markExternal l GHC.AnnVal  (showGhc n)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>+                             Annotate (GHC.ConDeclField name) where+  markAST _ (GHC.ConDeclField ns ty mdoc) = do+    mapM_ markLocated ns+    mark GHC.AnnDcolon+    markLocated ty+    markMaybe mdoc++-- ---------------------------------------------------------------------++instance Annotate GHC.HsDocString where+  markAST l (GHC.HsDocString s) = do+    markExternal l GHC.AnnVal (GHC.unpackFS s)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)+  => Annotate (GHC.Pat name) where+  markAST l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"+  -- TODO: probably wrong+  markAST l (GHC.VarPat n)  = markExternal l GHC.AnnVal (showGhc n)+  markAST _ (GHC.LazyPat p) = do+    mark GHC.AnnTilde+    markLocated p++  markAST _ (GHC.AsPat ln p) = do+    markLocated ln+    mark GHC.AnnAt+    markLocated p++  markAST _ (GHC.ParPat p) = do+    mark GHC.AnnOpenP+    markLocated p+    mark GHC.AnnCloseP++  markAST _ (GHC.BangPat p) = do+    mark GHC.AnnBang+    markLocated p++  markAST _ (GHC.ListPat ps _ _) = do+    mark GHC.AnnOpenS+    mapM_ markLocated ps+    mark GHC.AnnCloseS++  markAST _ (GHC.TuplePat pats b _) = do+    if b == GHC.Boxed then mark GHC.AnnOpenP+                      else markWithString GHC.AnnOpen "(#"+    mapM_ markLocated pats+    if b == GHC.Boxed then mark GHC.AnnCloseP+                      else markWithString GHC.AnnClose "#)"++  markAST _ (GHC.PArrPat ps _) = do+    markWithString GHC.AnnOpen "[:"+    mapM_ markLocated ps+    markWithString GHC.AnnClose ":]"++  markAST _ (GHC.ConPatIn n dets) = do+    markHsConPatDetails n dets++  markAST _ (GHC.ConPatOut {}) = return ()++  -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type)+  markAST _ (GHC.ViewPat e pat _) = do+    markLocated e+    mark GHC.AnnRarrow+    markLocated pat++  -- SplicePat (HsSplice id)+  markAST _ (GHC.SplicePat (GHC.HsSplice _ e)) = do+    markWithString GHC.AnnOpen "$(" -- '$('+    markLocated e+    markWithString GHC.AnnClose ")" -- ')'++  -- QuasiQuotePat (HsQuasiQuote id)+  -- TODO+  markAST l (GHC.QuasiQuotePat (GHC.HsQuasiQuote n _ q)) = do+    markExternal l GHC.AnnVal+      ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")++  -- LitPat HsLit+  markAST l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)++  -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id)+  markAST _ (GHC.NPat ol _ _) = do+    mark GHC.AnnMinus+    markLocated ol++  -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id)+  markAST _ (GHC.NPlusKPat ln ol _ _) = do+    markLocated ln+    markWithString GHC.AnnVal "+"  -- "+"+    markLocated ol++  markAST l (GHC.SigPatIn pat ty) = do+    markLocated pat+    mark GHC.AnnDcolon+    markAST l ty++  markAST _ (GHC.SigPatOut {}) = return ()++  -- CoPat HsAnnotated (Pat id) Type+  markAST _ (GHC.CoPat {}) = return ()++-- ---------------------------------------------------------------------+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++markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+                      => GHC.Located name -> GHC.HsConPatDetails name -> Annotated ()+markHsConPatDetails ln dets = do+  case dets of+    GHC.PrefixCon args -> do+      markLocated ln+      mapM_ markLocated args+    GHC.RecCon (GHC.HsRecFields fs _) -> do+      markLocated ln+      mark GHC.AnnOpenC -- '{'+      mapM_ markLocated fs+      mark GHC.AnnDotdot+      mark GHC.AnnCloseC -- '}'+    GHC.InfixCon a1 a2 -> do+      markLocated a1+      markLocated ln+      markLocated a2++markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+                    =>  [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated ()+markHsConDeclDetails lns dets = do+  case dets of+    GHC.PrefixCon args -> mapM_ markLocated args+    GHC.RecCon fs -> do+      mark GHC.AnnOpenC+      markLocated fs+      mark GHC.AnnCloseC+    GHC.InfixCon a1 a2 -> do+      markLocated a1+      mapM_ markLocated lns+      markLocated a2++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate [GHC.LConDeclField name] where+  markAST _ fs = do+       mark GHC.AnnOpenC -- '{'+       mapM_ markLocated fs+       mark GHC.AnnDotdot+       mark GHC.AnnCloseC -- '}'++-- ---------------------------------------------------------------------++instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where+  markAST l ol =+    let str = case GHC.ol_val ol of+                GHC.HsIntegral src _ -> src+                GHC.HsFractional l2   -> (GHC.fl_text l2)+                GHC.HsIsString src _ -> src+    in+    markExternal l GHC.AnnVal str++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate arg)+    => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where+  markAST _ (GHC.HsWB thing _ _ _) = markLocated thing++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) =>+                            Annotate (GHC.Stmt name (GHC.Located body)) where++  markAST _ (GHC.LastStmt body _) = markLocated body++  markAST _ (GHC.BindStmt pat body _ _) = do+    markLocated pat+    mark GHC.AnnLarrow+    markLocated body+    mark GHC.AnnVbar -- possible in list comprehension++  markAST _ (GHC.BodyStmt body _ _ _) = do+    markLocated body++  markAST _ (GHC.LetStmt lb) = do+    -- return () `debug` ("markP.LetStmt entered")+    mark GHC.AnnLet+    mark GHC.AnnOpenC -- '{'+    markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)+    mark GHC.AnnCloseC -- '}'+    -- return () `debug` ("markP.LetStmt done")++  markAST _ (GHC.ParStmt pbs _ _) = do+    mapM_ markParStmtBlock pbs++  markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do+    mapM_ markLocated stmts+    case form of+      GHC.ThenForm -> do+        mark GHC.AnnThen+        markLocated using+        mark GHC.AnnBy+        case by of+          Just b -> markLocated b+          Nothing -> return ()+      GHC.GroupForm -> do+        mark GHC.AnnThen+        mark GHC.AnnGroup+        mark GHC.AnnBy+        case by of+          Just b -> markLocated b+          Nothing -> return ()+        mark GHC.AnnUsing+        markLocated using++  markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do+    mark GHC.AnnRec+    mark GHC.AnnOpenC+    markInside GHC.AnnSemi+    mapM_ markLocated stmts+    mark GHC.AnnCloseC++-- ---------------------------------------------------------------------++markParStmtBlock :: (GHC.DataId name,GHC.OutputableBndr name, Annotate name)+  =>  GHC.ParStmtBlock name name -> Annotated ()+markParStmtBlock (GHC.ParStmtBlock stmts _ns _) =+  mapM_ markLocated stmts++-- ---------------------------------------------------------------------++-- | Local binds need to be indented as a group, and thus need to have a+-- SrcSpan around them so they can be processed via the normal+-- markLocated / exactPC machinery.+getLocalBindsSrcSpan :: GHC.HsLocalBinds name -> GHC.SrcSpan+getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsIn binds sigs))+  = case spans of+      []  -> GHC.noSrcSpan+      sss -> GHC.combineSrcSpans (head sss) (last sss)+  where+    spans = sort (map GHC.getLoc (GHC.bagToList binds) ++ map GHC.getLoc sigs)++getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsOut {}))+   = error "getLocalBindsSrcSpan: only valid after type checking"++getLocalBindsSrcSpan (GHC.HsIPBinds (GHC.IPBinds binds _))+  = case sort (map GHC.getLoc binds) of+      [] -> GHC.noSrcSpan+      sss -> GHC.combineSrcSpans (head sss) (last sss)++getLocalBindsSrcSpan (GHC.EmptyLocalBinds) = GHC.noSrcSpan++-- ---------------------------------------------------------------------++-- | Generate a SrcSpan that enclosed the given list+getListSrcSpan :: [GHC.Located a] -> GHC.SrcSpan+getListSrcSpan ls+  = case ls of+      []  -> GHC.noSrcSpan+      sss -> GHC.combineLocs (head sss) (last sss)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.HsLocalBinds name) where+  markAST _ lb = markHsLocalBinds lb++-- ---------------------------------------------------------------------++markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+                     => (GHC.HsLocalBinds name) -> Annotated ()+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do+    applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)+                       ++ prepareListAnnotation sigs+                         )+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {}))+   = error $ "markHsLocalBinds: only valid after type checking"++markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated binds+markHsLocalBinds (GHC.EmptyLocalBinds)                 = return ()++-- ---------------------------------------------------------------------++markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name,+                                               Annotate body)+                   => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body))+                   -> Annotated ()+markMatchGroup l (GHC.MG matches _ _ _)+  = markListWithLayout l matches++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,+                                               Annotate body)+  => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.HsExpr name) where+  markAST l (GHC.HsVar n)           = markAST l n+  markAST l (GHC.HsIPVar (GHC.HsIPName v))         =+    markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v)+  markAST l (GHC.HsOverLit ov)     = markAST l ov+  markAST l (GHC.HsLit lit)           = markAST l lit++  markAST l (GHC.HsLam match)       = do+    mark GHC.AnnLam+    markMatchGroup l match++  markAST l (GHC.HsLamCase _ match) = markMatchGroup l match++  markAST _ (GHC.HsApp e1 e2) = do+    markLocated e1+    markLocated e2++  markAST _ (GHC.OpApp e1 e2 _ e3) = do+    markLocated e1+    markLocated e2+    markLocated e3++  markAST _ (GHC.NegApp e _) = do+    mark GHC.AnnMinus+    markLocated e++  markAST _ (GHC.HsPar e) = do+    mark GHC.AnnOpenP -- '('+    markLocated e+    mark GHC.AnnCloseP -- ')'++  markAST _ (GHC.SectionL e1 e2) = do+    markLocated e1+    markLocated e2++  markAST _ (GHC.SectionR e1 e2) = do+    markLocated e1+    markLocated e2++  markAST _ (GHC.ExplicitTuple args b) = do+    if b == GHC.Boxed then mark GHC.AnnOpenP+                      else markWithString GHC.AnnOpen "(#"++    mapM_ markLocated args++    if b == GHC.Boxed then mark GHC.AnnCloseP+                      else markWithString GHC.AnnClose "#)"++  markAST l (GHC.HsCase e1 matches) = do+    mark GHC.AnnCase+    markLocated e1+    mark GHC.AnnOf+    mark GHC.AnnOpenC+    markInside GHC.AnnSemi+    markMatchGroup l matches+    mark GHC.AnnCloseC++  markAST _ (GHC.HsIf _ e1 e2 e3) = do+    mark GHC.AnnIf+    markLocated e1+    markOffset GHC.AnnSemi 0+    mark GHC.AnnThen+    markLocated e2+    markOffset GHC.AnnSemi 1+    mark GHC.AnnElse+    markLocated e3++  markAST _ (GHC.HsMultiIf _ rhs) = do+    mark GHC.AnnIf+    mapM_ markLocated rhs++  markAST _ (GHC.HsLet binds e) = do+    mark GHC.AnnLet+    setLayoutFlag GHC.AnnLet (do -- Make sure the 'in' gets indented too+      mark GHC.AnnOpenC+      markInside GHC.AnnSemi+      markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)+      mark GHC.AnnCloseC+      mark GHC.AnnIn+      markLocated e)++  markAST l (GHC.HsDo cts es _) = do+    mark GHC.AnnDo+    let (ostr,cstr,_isComp) =+          if isListComp cts+            then case cts of+                   GHC.PArrComp -> ("[:",":]",True)+                   _            -> ("[",  "]",True)+            else ("{","}",False)++    markWithString GHC.AnnOpen ostr+    mark GHC.AnnOpenS+    mark GHC.AnnOpenC+    markInside GHC.AnnSemi+    if isListComp cts+      then do+        markLocated (last es)+        mark GHC.AnnVbar+        mapM_ markLocated (init es)+      else do+        markListWithLayout l es+    mark GHC.AnnCloseS+    mark GHC.AnnCloseC+    markWithString GHC.AnnClose cstr++  markAST _ (GHC.ExplicitList _ _ es) = do+    mark GHC.AnnOpenS+    mapM_ markLocated es+    mark GHC.AnnCloseS++  markAST _ (GHC.ExplicitPArr _ es)   = do+    markWithString GHC.AnnOpen "[:"+    mapM_ markLocated es+    markWithString GHC.AnnClose ":]"++  markAST _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do+    markLocated n+    mark GHC.AnnOpenC+    mark GHC.AnnDotdot+    mapM_ markLocated fs+    mark GHC.AnnCloseC++  markAST _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do+    markLocated e+    mark GHC.AnnOpenC+    mark GHC.AnnDotdot+    mapM_ markLocated fs+    mark GHC.AnnCloseC++  markAST _ (GHC.ExprWithTySig e typ _) = do+    markLocated e+    mark GHC.AnnDcolon+    markLocated typ++  markAST _ (GHC.ExprWithTySigOut e typ) = do+    markLocated e+    mark GHC.AnnDcolon+    markLocated typ++  markAST _ (GHC.ArithSeq _ _ seqInfo) = do+    mark GHC.AnnOpenS -- '['+    case seqInfo of+        GHC.From e -> do+          markLocated e+          mark GHC.AnnDotdot+        GHC.FromTo e1 e2 -> do+          markLocated e1+          mark GHC.AnnDotdot+          markLocated e2+        GHC.FromThen e1 e2 -> do+          markLocated e1+          mark GHC.AnnComma+          markLocated e2+          mark GHC.AnnDotdot+        GHC.FromThenTo e1 e2 e3 -> do+          markLocated e1+          mark GHC.AnnComma+          markLocated e2+          mark GHC.AnnDotdot+          markLocated e3+    mark GHC.AnnCloseS -- ']'++  markAST _ (GHC.PArrSeq _ seqInfo) = do+    markWithString GHC.AnnOpen "[:" -- '[:'+    case seqInfo of+        GHC.From e -> do+          markLocated e+          mark GHC.AnnDotdot+        GHC.FromTo e1 e2 -> do+          markLocated e1+          mark GHC.AnnDotdot+          markLocated e2+        GHC.FromThen e1 e2 -> do+          markLocated e1+          mark GHC.AnnComma+          markLocated e2+          mark GHC.AnnDotdot+        GHC.FromThenTo e1 e2 e3 -> do+          markLocated e1+          mark GHC.AnnComma+          markLocated e2+          mark GHC.AnnDotdot+          markLocated e3+    markWithString GHC.AnnClose ":]" -- ':]'++  markAST _ (GHC.HsSCC src csFStr e) = do+    markWithString GHC.AnnOpen src -- "{-# SCC"+    markWithString GHC.AnnVal (GHC.unpackFS csFStr)+    markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"")+    markWithString GHC.AnnClose "#-}"+    markLocated e++  markAST _ (GHC.HsCoreAnn src csFStr e) = do+    markWithString GHC.AnnOpen src -- "{-# CORE"+    markWithString GHC.AnnVal (GHC.unpackFS csFStr)+    markWithString GHC.AnnClose "#-}"+    markLocated e+  -- TODO: make monomorphic+  markAST l (GHC.HsBracket (GHC.VarBr single v)) =+    let str =+          if single then ("'"  ++ showGhc v)+                    else ("''" ++ showGhc v)+    in+    markExternal l GHC.AnnVal str+  markAST _ (GHC.HsBracket (GHC.DecBrL ds)) = do+    markWithString GHC.AnnOpen "[d|"+    mark GHC.AnnOpenC+    mapM_ markLocated ds+    mark GHC.AnnCloseC+    markWithString GHC.AnnClose "|]"+  -- Introduced after the renamer+  markAST _ (GHC.HsBracket (GHC.DecBrG _)) = return ()+  markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do+    markWithString GHC.AnnOpen "[|"+    markLocated e+    markWithString GHC.AnnClose "|]"+  markAST _ (GHC.HsBracket (GHC.TExpBr e)) = do+    markWithString GHC.AnnOpen "[||"+    markLocated e+    markWithString GHC.AnnClose "||]"+  markAST _ (GHC.HsBracket (GHC.TypBr e)) = do+    markWithString GHC.AnnOpen "[t|"+    markLocated e+    markWithString GHC.AnnClose "|]"+  markAST _ (GHC.HsBracket (GHC.PatBr e)) = do+    markWithString GHC.AnnOpen  "[p|"+    markLocated e+    markWithString GHC.AnnClose "|]"++  markAST _ (GHC.HsRnBracketOut _ _) = return ()+  markAST _ (GHC.HsTcBracketOut _ _) = return ()++  markAST _ (GHC.HsSpliceE False (GHC.HsSplice _ e)) = do+    markWithString GHC.AnnOpen "$("+    markLocated e+    markWithString GHC.AnnClose ")"++  markAST _ (GHC.HsSpliceE True (GHC.HsSplice _ e)) = do+    markWithString GHC.AnnOpen "$$("+    markLocated e+    markWithString GHC.AnnClose ")"++  markAST l (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote n _ q)) = do+    markExternal l GHC.AnnVal+      ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")+++  markAST _ (GHC.HsProc p c) = do+    mark GHC.AnnProc+    markLocated p+    mark GHC.AnnRarrow+    markLocated c++  markAST _ (GHC.HsStatic e) = do+    mark GHC.AnnStatic+    markLocated e++  markAST _ (GHC.HsArrApp e1 e2 _ _ _) = do+    markLocated e1+    -- only one of the next 4 will be resent+    mark GHC.Annlarrowtail+    mark GHC.Annrarrowtail+    mark GHC.AnnLarrowtail+    mark GHC.AnnRarrowtail++    markLocated e2++  markAST _ (GHC.HsArrForm e _ cs) = do+    markWithString GHC.AnnOpen "(|"+    markLocated e+    mapM_ markLocated cs+    markWithString GHC.AnnClose "|)"++  markAST _ (GHC.HsTick _ _) = return ()+  markAST _ (GHC.HsBinTick _ _ _) = return ()++  markAST _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do+    -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'+    markWithString       GHC.AnnOpen  src+    markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING+    markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER+    markOffset GHC.AnnColon 0 -- ':'+    markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER+    mark   GHC.AnnMinus   -- '-'+    markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER+    markOffset GHC.AnnColon 1 -- ':'+    markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER+    markWithString   GHC.AnnClose  "#-}"+    markLocated e++  markAST l (GHC.EWildPat) = do+    markExternal l GHC.AnnVal "_"++  markAST _ (GHC.EAsPat ln e) = do+    markLocated ln+    mark GHC.AnnAt+    markLocated e++  markAST _ (GHC.EViewPat e1 e2) = do+    markLocated e1+    mark GHC.AnnRarrow+    markLocated e2++  markAST _ (GHC.ELazyPat e) = do+    mark GHC.AnnTilde+    markLocated e++  markAST _ (GHC.HsType ty) = markLocated ty++  markAST _ (GHC.HsWrap _ _) = return ()+  markAST _ (GHC.HsUnboundVar _) = return ()++instance Annotate GHC.HsLit where+  markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)+-- ---------------------------------------------------------------------++-- |Used for declarations that need to be aligned together, e.g. in a+-- do or let .. in statement/expr+instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate ([GHC.ExprLStmt name]) where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.HsTupArg name) where+  markAST _ (GHC.Present e) = do+    markLocated e++  markAST _ (GHC.Missing _) = do+    mark GHC.AnnComma++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate (GHC.HsCmdTop name) where+  markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+   => Annotate (GHC.HsCmd name) where+  markAST _ (GHC.HsCmdArrApp e1 e2 _ _ _) = do+    markLocated e1+    -- only one of the next 4 will be resent+    mark GHC.Annlarrowtail+    mark GHC.Annrarrowtail+    mark GHC.AnnLarrowtail+    mark GHC.AnnRarrowtail++    markLocated e2++  markAST _ (GHC.HsCmdArrForm e _mf cs) = do+    markWithString GHC.AnnOpen "(|"+    markLocated e+    mapM_ markLocated cs+    markWithString GHC.AnnClose "|)"++  markAST _ (GHC.HsCmdApp e1 e2) = do+    markLocated e1+    markLocated e2++  markAST l (GHC.HsCmdLam match) = do+    mark GHC.AnnLam+    markMatchGroup l match++  markAST _ (GHC.HsCmdPar e) = do+    mark GHC.AnnOpenP+    markLocated e+    mark GHC.AnnCloseP -- ')'++  markAST l (GHC.HsCmdCase e1 matches) = do+    mark GHC.AnnCase+    markLocated e1+    mark GHC.AnnOf+    mark GHC.AnnOpenC+    markMatchGroup l matches+    mark GHC.AnnCloseC++  markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do+    mark GHC.AnnIf+    markLocated e1+    markOffset GHC.AnnSemi 0+    mark GHC.AnnThen+    markLocated e2+    markOffset GHC.AnnSemi 1+    mark GHC.AnnElse+    markLocated e3++  markAST _ (GHC.HsCmdLet binds e) = do+    mark GHC.AnnLet+    mark GHC.AnnOpenC+    markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)+    mark GHC.AnnCloseC+    mark GHC.AnnIn+    markLocated e++  markAST l (GHC.HsCmdDo es _) = do+    mark GHC.AnnDo+    mark GHC.AnnOpenC+    -- mapM_ markLocated es+    markListWithLayout l es+    mark GHC.AnnCloseC++  markAST _ (GHC.HsCmdCast {}) = error $ "markP.HsCmdCast: only valid after type checker"+++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where+  markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+     => Annotate (GHC.TyClDecl name) where++  markAST l (GHC.FamDecl famdecl) = markAST l famdecl++  markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do+    mark GHC.AnnType+    markLocated ln+    mapM_ markLocated tyvars+    mark GHC.AnnEqual+    markLocated typ++  markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)+                (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do+    mark GHC.AnnData+    mark GHC.AnnNewtype+    markMaybe mctyp+    markLocated ctx+    mark GHC.AnnDarrow+    markTyClass ln tyVars+    mark GHC.AnnDcolon+    markMaybe mk+    mark GHC.AnnEqual+    mark GHC.AnnWhere+    mapM_ markLocated cons+    markMaybe mderivs++  -- -----------------------------------++  markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds+                          sigs meths ats atdefs docs _) = do+    mark GHC.AnnClass+    markLocated ctx++    markTyClass ln tyVars++    mark GHC.AnnVbar+    mapM_ markLocated fds+    mark GHC.AnnWhere+    mark GHC.AnnOpenC -- '{'+    markInside GHC.AnnSemi+    applyListAnnotations (prepareListAnnotation sigs+                       ++ prepareListAnnotation (GHC.bagToList meths)+                       ++ prepareListAnnotation ats+                       ++ prepareListAnnotation atdefs+                       ++ prepareListAnnotation docs+                         )+    mark GHC.AnnCloseC -- '}'++-- ---------------------------------------------------------------------++markTyClass :: (Annotate a, Annotate ast)+                => GHC.Located a -> [GHC.Located ast] -> Annotated ()+markTyClass ln tyVars = do+    markMany GHC.AnnOpenP+    applyListAnnotations (prepareListAnnotation [ln]+                      ++ prepareListAnnotation (take 2 tyVars))+    markMany GHC.AnnCloseP+    mapM_ markLocated (drop 2 tyVars)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name)+   => Annotate (GHC.FamilyDecl name) where+  markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do+    mark GHC.AnnType+    mark GHC.AnnData+    mark GHC.AnnFamily+    markLocated ln+    mapM_ markLocated tyvars+    mark GHC.AnnDcolon+    markMaybe mkind+    mark GHC.AnnWhere+    mark GHC.AnnOpenC -- {+    case info of+      GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns+      _ -> return ()+    case info of+      GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns+      _ -> return ()+    mark GHC.AnnCloseC -- }++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)+   => Annotate (GHC.TyFamInstEqn name) where+  markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do+    markLocated ln+    mapM_ markLocated pats+    mark GHC.AnnEqual+    markLocated typ+++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)+  => Annotate (GHC.TyFamDefltEqn name) where+  markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do+    markLocated ln+    mapM_ markLocated bndrs+    mark GHC.AnnEqual+    markLocated typ++-- ---------------------------------------------------------------------++-- TODO: modify lexer etc, in the meantime to not set haddock flag+instance Annotate GHC.DocDecl where+  markAST l v =+    let str =+          case v of+            (GHC.DocCommentNext (GHC.HsDocString fs)) -> (GHC.unpackFS fs)+            (GHC.DocCommentPrev (GHC.HsDocString fs)) -> (GHC.unpackFS fs)+            (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> (GHC.unpackFS fs)+            (GHC.DocGroup _i (GHC.HsDocString fs)) -> (GHC.unpackFS fs)+    in+      markExternal l (GHC.AnnVal) str++-- ---------------------------------------------------------------------++markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+  => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated ()+markDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do+  markLocated ctx+  markMaybe typ+  markMaybe mk+  mapM_ markLocated cons+  case mderivs of+    Nothing -> return ()+    Just d -> markLocated d++-- ---------------------------------------------------------------------++-- Note: GHC.HsContext name aliases to here too+instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)+     => Annotate [GHC.LHsType name] where+  markAST l ts = do+    return () `debug` ("markP.HsContext:l=" ++ showGhc l)+    mark GHC.AnnDeriving+    mark GHC.AnnOpenP+    mapM_ markLocated ts+    mark GHC.AnnCloseP+    mark GHC.AnnDarrow++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)+      => Annotate (GHC.ConDecl name) where+  markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx+                         dets res _ _) = do+    case res of+      GHC.ResTyH98 -> do+        mark GHC.AnnForall+        mapM_ markLocated bndrs+        mark GHC.AnnDot++        markLocated ctx+        mark GHC.AnnDarrow++        case dets of+          GHC.InfixCon _ _ -> return ()+          _ -> mapM_ markLocated lns++        markHsConDeclDetails lns dets++      GHC.ResTyGADT ls ty -> do+        -- only print names if not infix+        case dets of+          GHC.InfixCon _ _ -> return ()+          _ -> mapM_ markLocated lns++        markHsConDeclDetails lns dets++        mark GHC.AnnDcolon++        markLocated (GHC.L ls (ResTyGADTHook bndrs))++        markLocated ctx+        mark GHC.AnnDarrow++        markLocated ty+++    mark GHC.AnnVbar++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>+              Annotate (ResTyGADTHook name) where+  markAST _ (ResTyGADTHook bndrs) = do+    mark GHC.AnnForall+    mapM_ markLocated bndrs+    mark GHC.AnnDot++-- ---------------------------------------------------------------------++instance (Annotate name,Annotate a)+  => Annotate (GHC.HsRecField name (GHC.Located a)) where+  markAST _ (GHC.HsRecField n e _) = do+    markLocated n+    mark GHC.AnnEqual+    markLocated e++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name)+    => Annotate (GHC.FunDep (GHC.Located name)) where++  markAST _ (ls,rs) = do+    mapM_ markLocated ls+    mark GHC.AnnRarrow+    mapM_ markLocated rs++-- ---------------------------------------------------------------------++instance Annotate (GHC.CType) where+  markAST _ (GHC.CType src mh f) = do+    markWithString GHC.AnnOpen src+    case mh of+      Nothing -> return ()+      Just (GHC.Header h) ->+         markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"")+    markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"")+    markWithString GHC.AnnClose "#-}"++-- ---------------------------------------------------------------------
+ src/Language/Haskell/GHC/ExactPrint/Delta.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE NamedFieldPuns #-}+module Language.Haskell.GHC.ExactPrint.Delta  (relativiseApiAnns) where++import Control.Monad.RWS+import Control.Applicative+import Control.Monad.Trans.Free++import Data.Data (Data)+import Data.List (sort, nub, partition)+import Data.Maybe (fromMaybe)++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated+                                                , markLocated, Annotate(..))++import qualified GHC+import qualified SrcLoc         as GHC++import qualified Data.Map as Map+++-- ---------------------------------------------------------------------+--+-- | Type used in the Delta Monad. The state variables maintain+--    - the current SrcSpan and the constructor of the thing it encloses+--      as a stack to the root of the AST as it is traversed,+--    - the srcspan of the last thing annotated, to calculate delta's from+--    - extra data needing to be stored in the monad+--    - the annotations provided by GHC+type Delta a = RWS DeltaStack DeltaWriter DeltaState a++-- | Transform concrete annotations into relative annotations which are+-- more useful when transforming an AST.+relativiseApiAnns :: Annotate ast+                  => GHC.Located ast+                  -> GHC.ApiAnns+                  -> Anns+relativiseApiAnns modu@(GHC.L ss _) ghcAnns+   = runDelta (markLocated modu) ghcAnns ss+++runDelta :: Annotated () -> GHC.ApiAnns -> GHC.SrcSpan -> Anns+runDelta action ga priorEnd =+  ($ mempty) . appEndo . finalAnns . snd+  . (\next -> execRWS next initialDeltaStack (defaultDeltaState priorEnd ga))+  . simpleInterpret $ action++-- ---------------------------------------------------------------------++data DeltaState = DeltaState+             { -- | Position reached when processing the last element+               priorEndPosition :: GHC.SrcSpan+               -- | Ordered list of comments still to be allocated+             , apComments :: [Comment]+               -- | The original GHC Delta Annotations+             , apAnns :: GHC.ApiAnns+             }++data DeltaStack = DeltaStack+               { -- | Current `SrcSpan`+                 curSrcSpan :: GHC.SrcSpan+                 -- | Constuctor of current AST element, useful for+                 -- debugging+               , annConName :: AnnConName+                 -- | Start column of the current layout block+               , layoutStart :: LayoutStartCol+               }++initialDeltaStack :: DeltaStack+initialDeltaStack =+  DeltaStack+    { curSrcSpan = GHC.noSrcSpan+    , annConName = annGetConstr ()+    , layoutStart = 0+    }++defaultDeltaState :: GHC.SrcSpan -> GHC.ApiAnns -> DeltaState+defaultDeltaState priorEnd ga =+    DeltaState+      { priorEndPosition = priorEnd+      , apComments = cs+      , apAnns     = ga    -- $+      }+  where+    cs :: [Comment]+    cs = flattenedComments ga++    flattenedComments :: GHC.ApiAnns -> [Comment]+    flattenedComments (_,cm) =+      map tokComment . GHC.sortLocated . concat $ Map.elems cm++    tokComment :: GHC.Located GHC.AnnotationComment -> Comment+    tokComment t@(GHC.L lt _) = Comment (ss2span lt) (ghcCommentText t)+++data DeltaWriter = DeltaWriter+  { -- Final list of annotations+    finalAnns :: Endo (Map.Map AnnKey Annotation)+    -- Used locally to pass Keywords, delta pairs relevant to a specific+    -- subtree to the parent.+  , annKds :: [(KeywordId, DeltaPos)]+    -- Used locally to report a subtrees aderhence to haskell's layout+    -- rules.+  , propOffset :: First LayoutStartCol -- Used to pass the offset upwards+  }++-- Writer helpers++tellFinalAnn :: (AnnKey, Annotation) -> Delta ()+tellFinalAnn (k, v) =+  tell (mempty { finalAnns = Endo (Map.insertWith (<>) k v) })++tellKd :: (KeywordId, DeltaPos) -> Delta ()+tellKd kd = tell (mempty { annKds = [kd] })+++instance Monoid DeltaWriter where+  mempty = DeltaWriter mempty mempty mempty+  (DeltaWriter a b e) `mappend` (DeltaWriter c d f) = DeltaWriter (a <> c) (b <> d) (e <> f)++-----------------------------------+-- Interpretation code++simpleInterpret :: Annotated a -> Delta a+simpleInterpret = iterTM go+  where+    go :: AnnotationF (Delta a) -> Delta a+    go (MarkEOF next) = addEofAnnotation >> next+    go (MarkPrim kwid _ next) =+      addDeltaAnnotation kwid >> next+    go (MarkOutside akwid kwid next) =+      addDeltaAnnotationsOutside akwid kwid >> next+    go (MarkInside akwid next) =+      addDeltaAnnotationsInside akwid >> next+    go (MarkMany akwid next) = addDeltaAnnotations akwid >> next+    go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next+    go (MarkAfter akwid next) = addDeltaAnnotationAfter akwid >> next+    go (WithAST lss layoutflag prog next) =+      withAST lss layoutflag (simpleInterpret prog) >> next+    go (OutputKD (kwid, (_, dp)) next) = tellKd (dp, kwid) >> next+    go (CountAnns kwid next) = countAnnsDelta kwid >>= next+    go (SetLayoutFlag kwid action next) = setLayoutFlag kwid (simpleInterpret action)  >> next+    go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next+++-- | Used specifically for "HsLet"+setLayoutFlag :: GHC.AnnKeywordId -> Delta () -> Delta ()+setLayoutFlag kwid action = do+  c <-  srcSpanStartColumn . head <$> getAnnotationDelta kwid+  tell (mempty { propOffset = First  (Just (LayoutStartCol c)) })+  local (\s -> s { layoutStart = LayoutStartCol c }) action+++-- -------------------------------------++getSrcSpan :: Delta GHC.SrcSpan+getSrcSpan = asks curSrcSpan++withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b+withSrcSpanDelta (GHC.L l a) =+  local (\s -> s { curSrcSpan = l+                 , annConName = annGetConstr a+                 })++++getUnallocatedComments :: Delta [Comment]+getUnallocatedComments = gets apComments++putUnallocatedComments :: [Comment] -> Delta ()+putUnallocatedComments cs = modify (\s -> s { apComments = cs } )++-- ---------------------------------------------------------------------++adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos+adjustDeltaForOffsetM dp = do+  colOffset <- asks layoutStart+  return (adjustDeltaForOffset colOffset dp)++adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos+adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line+adjustDeltaForOffset  (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset)++-- ---------------------------------------------------------------------++getPriorEnd :: Delta GHC.SrcSpan+getPriorEnd = gets priorEndPosition++setPriorEnd :: GHC.SrcSpan -> Delta ()+setPriorEnd pe = modify (\s -> s { priorEndPosition = pe })++setLayoutOffset :: LayoutStartCol -> Delta a -> Delta a+setLayoutOffset lhs = local (\s -> s { layoutStart = lhs })++-- -------------------------------------++getAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+getAnnotationDelta an = do+    ga <- gets apAnns+    ss <- getSrcSpan+    return $ GHC.getAnnotation ga ss an++getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+getAndRemoveAnnotationDelta sp an = do+    ga <- gets apAnns+    let (r,ga') = GHC.getAndRemoveAnnotation ga sp an+    r <$ modify (\s -> s { apAnns = ga' })++-- -------------------------------------++-- |Add some annotation to the currently active SrcSpan+addAnnotationsDelta :: Annotation -> Delta ()+addAnnotationsDelta ann = do+    l <- ask+    tellFinalAnn (getAnnKey l ,ann)++getAnnKey :: DeltaStack -> AnnKey+getAnnKey DeltaStack {curSrcSpan, annConName} = AnnKey curSrcSpan annConName++-- -------------------------------------++addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta ()+addAnnDeltaPos kw dp = tellKd (kw, dp)++-- -------------------------------------+++-- | Enter a new AST element. Maintain SrcSpan stack+withAST :: Data a => GHC.Located a -> LayoutFlag -> Delta b -> Delta b+withAST lss@(GHC.L ss _) layout action = do+  -- Calculate offset required to get to the start of the SrcSPan+  pe <- getPriorEnd+  off <- asks layoutStart+  let whenLayout = case layout of+                        LayoutRules ->+                          setLayoutOffset+                            (LayoutStartCol (srcSpanStartColumn ss))+                        NoLayoutRules -> id+  (whenLayout .  withSrcSpanDelta lss) (do++    let maskWriter s = s { annKds = []+                         , propOffset = First Nothing }++    (res, w) <- censor maskWriter (listen action)+    let edp = adjustDeltaForOffset+                -- Use the propagated offset if one is set+                (fromMaybe off (getFirst $ propOffset w))+                  (deltaFromSrcSpans pe ss)+    let kds = annKds w+    addAnnotationsDelta Ann+                          { annEntryDelta = edp+                          , annDelta   = ColDelta (srcSpanStartColumn ss+                                                    - getLayoutStartCol off)+                          , annsDP     = kds }+    --  `debug` ("leaveAST:(ss,finaledp,dp,nl,kds)=" ++ show (showGhc ss,edp,dp,nl,kds))+    return res)++-- ---------------------------------------------------------------------++-- |Split the ordered list of comments into ones that occur prior to+-- the given SrcSpan and the rest+allocatePriorComments :: [Comment] -> GHC.SrcSpan -> ([Comment],[Comment])+allocatePriorComments cs ss = partition isPrior cs+  where+    (start,_) = ss2span ss+    isPrior (Comment s _)  = fst s < start+      `debug` ("allocatePriorComments:(s,ss,cond)=" ++ showGhc (s,ss,(fst s) < start))++-- ---------------------------------------------------------------------++addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta ()+addAnnotationWorker ann pa = do+  unless (isPointSrcSpan pa) $+    do+      pe <- getPriorEnd+      ss <- getSrcSpan+      let p = deltaFromSrcSpans pe pa+      case (ann,isGoodDelta p) of+        (G GHC.AnnComma,False) -> return ()+        (G GHC.AnnSemi, False) -> return ()+        (G GHC.AnnOpen, False) -> return ()+        (G GHC.AnnClose,False) -> return ()+        _ -> do+          cs <- getUnallocatedComments+          let (allocated,cs') = allocatePriorComments cs pa+          putUnallocatedComments cs'+          return () `debug`("addAnnotationWorker:(ss,pa,allocated,cs)=" ++ showGhc (ss,pa,allocated,cs))+          mapM_ addDeltaComment allocated+          p' <- adjustDeltaForOffsetM p+          addAnnDeltaPos ann p'+          setPriorEnd pa+              -- `debug` ("addDeltaAnnotationWorker:(ss,pe,pa,p,ann)=" ++ show (ss2span ss,ss2span pe,ss2span pa,p,ann))++-- ---------------------------------------------------------------------++addDeltaComment :: Comment -> Delta ()+addDeltaComment (Comment paspan str) = do+  let pa = span2ss paspan+  pe <- getPriorEnd+  let p = deltaFromSrcSpans pe pa+  p' <- adjustDeltaForOffsetM p+  setPriorEnd pa+  let e = ss2deltaP (ss2posEnd pe) (snd paspan)+  e' <- adjustDeltaForOffsetM e+  addAnnDeltaPos (AnnComment (DComment (p',e') str)) p'++-- ---------------------------------------------------------------------++-- | Look up and add a Delta annotation at the current position, and+-- advance the position to the end of the annotation+addDeltaAnnotation :: GHC.AnnKeywordId -> Delta ()+addDeltaAnnotation ann = do+  ss <- getSrcSpan+  when (ann == GHC.AnnVal) (debugM (showGhc ss))+  ma <- getAnnotationDelta ann+  when (ann == GHC.AnnVal && null ma) (debugM "empty")+  case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier+    [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show ann)+    [pa] -> addAnnotationWorker (G ann) pa+    _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma)++-- | Look up and add a Delta annotation appearing beyond the current+-- SrcSpan at the current position, and advance the position to the+-- end of the annotation+addDeltaAnnotationAfter :: GHC.AnnKeywordId -> Delta ()+addDeltaAnnotationAfter ann = do+  ss <- getSrcSpan+  ma <- getAnnotationDelta ann+  let ma' = filter (\s -> not (GHC.isSubspanOf s ss)) ma+  case ma' of+    [] -> return () `debug` "addDeltaAnnotation empty ma"+    [pa] -> addAnnotationWorker (G ann) pa+    _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma)++-- | Look up and add a Delta annotation at the current position, and+-- advance the position to the end of the annotation+addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta ()+addDeltaAnnotationLs ann off = do+  ma <- getAnnotationDelta ann+  case drop off ma of+    [] -> return ()+        -- `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma))+    (pa:_) -> addAnnotationWorker (G ann) pa++-- | Look up and add possibly multiple Delta annotation at the current+-- position, and advance the position to the end of the annotations+addDeltaAnnotations :: GHC.AnnKeywordId -> Delta ()+addDeltaAnnotations ann = do+  ma <- getAnnotationDelta ann+  let do_one ap' = addAnnotationWorker (G ann) ap'+                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))+  mapM_ do_one (sort ma)++-- | Look up and add possibly multiple Delta annotations enclosed by+-- the current SrcSpan at the current position, and advance the+-- position to the end of the annotations+addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta ()+addDeltaAnnotationsInside ann = do+  ss <- getSrcSpan+  ma <- getAnnotationDelta ann+  let do_one ap' = addAnnotationWorker (G ann) ap'+                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))+  let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma+  mapM_ do_one filtered++-- | Look up and add possibly multiple Delta annotations not enclosed by+-- the current SrcSpan at the current position, and advance the+-- position to the end of the annotations+addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta ()+addDeltaAnnotationsOutside gann ann = do+  ss <- getSrcSpan+  unless (ss2span ss == ((1,1),(1,1))) $+    do+      -- ma <- getAnnotationDelta ss gann+      ma <- getAndRemoveAnnotationDelta ss gann+      let do_one ap' = addAnnotationWorker ann ap'+      mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma)++-- | Add a Delta annotation at the current position, and advance the+-- position to the end of the annotation+addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ()+addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s++addEofAnnotation :: Delta ()+addEofAnnotation = do+  pe <- getPriorEnd+  ma <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos)+  case ma of+    [] -> return ()+    (pa:pss) -> do+      cs <- getUnallocatedComments+      mapM_ addDeltaComment cs+      let DP (r,c) = deltaFromSrcSpans pe pa+      addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1))+      setPriorEnd pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss)+++countAnnsDelta :: GHC.AnnKeywordId -> Delta Int+countAnnsDelta ann = do+  ma <- getAnnotationDelta ann+  return (length ma)+++
+ src/Language/Haskell/GHC/ExactPrint/Lookup.hs view
@@ -0,0 +1,90 @@+module Language.Haskell.GHC.ExactPrint.Lookup (keywordToString) where++import GHC (AnnKeywordId(..))++-- | Maps `AnnKeywordId` to the corresponding String representation.+-- There is no specific mapping for the following constructors.+-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`,+-- `AnnInfix`+keywordToString :: AnnKeywordId -> String+keywordToString kw =+  let mkErr x = error $ "keywordToString: missing case for:" ++ show x+  in+  case kw of+      -- Specifically handle all cases so that there are pattern match+      -- warnings if new constructors are added.+      AnnOpen  -> mkErr kw+      AnnClose -> mkErr kw+      AnnVal   -> mkErr kw+      AnnPackageName -> mkErr kw+      AnnHeader -> mkErr kw+      AnnFunId -> mkErr kw+      AnnInfix  -> mkErr kw+      AnnValStr -> mkErr kw+      AnnAs    -> "as"+      AnnAt   -> "@"+      AnnBang  -> "!"+      AnnBackquote   -> "`"+      AnnBy   -> "by"+      AnnCase  -> "case"+      AnnClass    -> "class"+      AnnCloseC  -> "}"+      AnnCloseP  -> ")"+      AnnCloseS  -> "]"+      AnnColon    -> ":"+      AnnComma   -> ","+      AnnCommaTuple  -> ","+      AnnDarrow  -> "=>"+      AnnData   -> "data"+      AnnDcolon  -> "::"+      AnnDefault    -> "default"+      AnnDeriving   -> "deriving"+      AnnDo   -> "do"+      AnnDot   -> "."+      AnnDotdot  -> ".."+      AnnElse   -> "else"+      AnnEqual    -> "="+      AnnExport   -> "export"+      AnnFamily   -> "family"+      AnnForall   -> "forall"+      AnnForeign    -> "foreign"+      AnnGroup    -> "group"+      AnnHiding   -> "hiding"+      AnnIf   -> "if"+      AnnImport   -> "import"+      AnnIn   -> "in"+      AnnInstance   -> "instance"+      AnnLam    -> "\\"+      AnnLarrow  -> "<-"+      AnnLet    -> "let"+      AnnMdo    -> "mdo"+      AnnMinus   -> "-"+      AnnModule   -> "module"+      AnnNewtype   -> "newtype"+      AnnOf   -> "of"+      AnnOpenC   -> "{"+      AnnOpenP   -> "("+      AnnOpenS   -> "["+      AnnPattern    -> "pattern"+      AnnProc   -> "proc"+      AnnQualified   -> "qualified"+      AnnRarrow  -> "->"+      AnnRec    -> "rec"+      AnnRole   -> "role"+      AnnSafe   -> "safe"+      AnnSemi  -> ";"+      AnnStatic  -> "static"+      AnnThen   -> "then"+      AnnTilde   -> "~"+      AnnTildehsh  -> "~#"+      AnnType   -> "type"+      AnnUnit  -> "()"+      AnnUsing    -> "using"+      AnnVbar  -> "|"+      AnnWhere    -> "where"+      Annlarrowtail  -> "-<"+      Annrarrowtail  -> "->"+      AnnLarrowtail  -> "-<<"+      AnnRarrowtail  -> ">>-"+      AnnEofPos -> ""+
+ src/Language/Haskell/GHC/ExactPrint/Print.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE NamedFieldPuns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.GHC.ExactPrint.Print+--+-----------------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint.Print+        (+          Anns+        , exactPrintWithAnns++        , exactPrint++        ) where++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils ( debug, undelta, isGoodDelta, showGhc, )+import Language.Haskell.GHC.ExactPrint.Annotate+  (AnnotationF(..), Annotated, Annotate(..), markLocated)+import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString)+import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns )++import Control.Applicative+import Control.Monad.RWS+import Data.Data (Data)+import Data.List (partition)+import Data.Maybe (mapMaybe, fromMaybe, maybeToList)++import Control.Monad.Trans.Free++import qualified GHC++------------------------------------------------------------------------------+-- Printing of source elements++-- | Print an AST exactly as specified by the annotations on the nodes in the tree.+-- The output of this function should exactly match the source file.+exactPrint :: Annotate ast => GHC.Located ast -> GHC.ApiAnns -> String+exactPrint ast ghcAnns = exactPrintWithAnns ast relativeAnns+  where+    relativeAnns = relativiseApiAnns ast ghcAnns++-- | Print an AST with a map of potential modified `Anns`. The usual way to+-- generate such a map is by calling `relativiseApiAnns`.+exactPrintWithAnns :: Annotate ast+                     => GHC.Located ast+                     -> Anns+                     -> String+exactPrintWithAnns ast an = runEP (markLocated ast) an+++------------------------------------------------------+-- The EP monad and basic combinators++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 EPStack = EPStack+            {  epLHS      :: LayoutStartCol -- ^ Marks the column of the LHS of the i+                                  --   current layout block+             }++defaultEPState :: Anns -> EPState+defaultEPState as = EPState+             { epPos    = (1,1)+             , epAnns   = as+             , epAnnKds = []+             }++initialEPStack :: EPStack+initialEPStack  = EPStack+             { epLHS = 0+             }++data EPWriter = EPWriter+              { output :: Endo String }++instance Monoid EPWriter where+  mempty = EPWriter mempty+  (EPWriter a) `mappend` (EPWriter c) = EPWriter (a <> c)++---------------------------------------------------------++type EP a = RWS EPStack EPWriter EPState a++runEP :: Annotated () -> Anns -> String+runEP action ans =+  flip appEndo "" . output . snd+  . (\next -> execRWS next initialEPStack (defaultEPState ans))+  . printInterpret $ action+++++printInterpret :: Annotated a -> EP a+printInterpret = iterTM go+  where+    go :: AnnotationF (EP a) -> EP a+    go (MarkEOF next) =+      printStringAtMaybeAnn (G GHC.AnnEofPos) "" >> next+    go (MarkPrim kwid mstr next) =+      let annString = fromMaybe (keywordToString kwid) mstr in+        printStringAtMaybeAnn (G kwid) annString >> next+    go (MarkOutside _ kwid next) =+      printStringAtMaybeAnnAll kwid ";"  >> next+    go (MarkInside akwid next) =+      allAnns akwid >> next+    go (MarkMany akwid next) =+      allAnns akwid >> next+    go (MarkOffsetPrim kwid _ mstr next) =+      let annString = fromMaybe (keywordToString kwid) mstr in+        printStringAtMaybeAnn (G kwid) annString >> next+    go (MarkAfter akwid next) =+      justOne akwid >> next+    go (WithAST lss flag action next) =+      exactPC lss flag (NoLayoutRules <$ printInterpret action) >> next+    go (OutputKD _ next) =+      next+    go (CountAnns kwid next) =+      countAnnsEP (G kwid) >>= next+    go (SetLayoutFlag kwid action next) =+      setLayout kwid (printInterpret action) >> next+    go (MarkExternal _ akwid s next) =+      printStringAtMaybeAnn (G akwid) s >> next++justOne, allAnns :: GHC.AnnKeywordId -> EP ()+justOne kwid = printStringAtMaybeAnn (G kwid) (keywordToString kwid)+allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString kwid)++-------------------------------------------------------------------------+-- |First move to the given location, then call exactP+exactPC :: Data ast => GHC.Located ast -> LayoutFlag -> EP LayoutFlag -> EP LayoutFlag+exactPC ast flag action =+    do return () `debug` ("exactPC entered for:" ++ showGhc (GHC.getLoc ast))+       ma <- getAndRemoveAnnotation ast+       let an@(Ann _ _ kds) = fromMaybe annNone ma+       withContext kds an flag action++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++withContext :: [(KeywordId, DeltaPos)]+            -> Annotation+            -> LayoutFlag+            -> EP LayoutFlag -> EP LayoutFlag+withContext kds an flag = withKds kds . withOffset an flag++-- ---------------------------------------------------------------------+--+-- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous+-- offset+--+withOffset :: Annotation -> LayoutFlag -> (EP LayoutFlag -> EP LayoutFlag)+withOffset Ann{annEntryDelta, annDelta} flag k = do+  let DP (edLine, edColumn) = annEntryDelta+  oldOffset <-  asks epLHS -- Shift from left hand column+  (_l, currentColumn) <- getPos+  rec+    -- Calculate the new offset+    -- 1. If the LayoutRules flag is set then we need to mark this position+    -- as the start of a new layout block.+    -- There are two cases (1) If we are on the same line  and (2) if we+    -- move to a new line.+    -- (1) The start of the layout block is the current position added to+    -- the delta+    -- (2) The start of the layout block is the old offset added to the+    -- "annOffset" (i.e., how far this annotation was from the edge)+    let offset = case flag <> f of+                       LayoutRules -> LayoutStartCol $+                        if edLine == 0+                          then currentColumn + edColumn+                          else getLayoutStartCol oldOffset + getColDelta annDelta+                       NoLayoutRules -> oldOffset+    f <-  local (\s -> s { epLHS = offset }) k+  return f+++-- ---------------------------------------------------------------------+--+-- Necessary as there are destructive gets of Kds across scopes+withKds :: [(KeywordId, DeltaPos)] -> EP a -> EP a+withKds kd action = do+  modify (\s -> s { epAnnKds = kd : epAnnKds s })+  r <- action+  modify (\s -> s { epAnnKds = tail (epAnnKds s) })+  return r++------------------------------------------------------------------------++setLayout :: GHC.AnnKeywordId -> EP () -> EP LayoutFlag+setLayout akiwd k = do+  p <- gets epPos+  local (\s -> s { epLHS = LayoutStartCol (snd p - length (keywordToString akiwd))})+                  (LayoutRules <$ k)++getPos :: EP Pos+getPos = gets epPos++setPos :: Pos -> EP ()+setPos l = modify (\s -> s {epPos = l})++-- |Get the current column offset+getLayoutOffset :: EP LayoutStartCol+getLayoutOffset = asks epLHS++-- ---------------------------------------------------------------------++printStringAtMaybeAnn :: KeywordId -> String -> EP ()+printStringAtMaybeAnn an str = do+  (comments, ma) <- getAnnFinal an+  printStringAtLsDelta comments (maybeToList ma) str+    -- ++AZ++: Enabling the following line causes a very weird error associated with AnnPackageName. I suspect it is because it is forcing the evaluation of a non-existent an or 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+        Nothing -> return ()+        Just d  -> printStringAtLsDelta comments [d] str >> go++-- ---------------------------------------------------------------------+++-- |destructive get, hence use an annotation once only+getAnnFinal :: KeywordId -> EP ([DComment], Maybe DeltaPos)+getAnnFinal kw = do+  kd <- gets epAnnKds+  let (r, kd', dcs) = case kd of+                  []    -> (Nothing ,[], [])+                  (k:kds) -> (r',kk:kds, dcs')+                    where (cs', r',kk) = destructiveGetFirst kw ([],k)+                          dcs' = mapMaybe keywordIdToDComment cs'+  modify (\s -> s { epAnnKds = kd' })+  return (dcs, r)++keywordIdToDComment :: (KeywordId, DeltaPos) -> Maybe DComment+keywordIdToDComment (AnnComment comment,_dp) = Just comment+keywordIdToDComment _                   = Nothing++-- | 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)], Maybe v,[(KeywordId,v)])+destructiveGetFirst _key (acc,[]) = ([], Nothing ,acc)+destructiveGetFirst  key (acc, (k,v):kvs )+  | k == key = let (cs,others) = commentsAndOthers acc in (cs, Just v ,others++kvs)+  | otherwise = destructiveGetFirst key (acc++[(k,v)],kvs)+  where+    commentsAndOthers kvs' = partition isComment kvs'+    isComment (AnnComment _ , _ ) = True+    isComment _              = False++-- ---------------------------------------------------------------------++-- |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 <- getLayoutOffset+      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 -> LayoutStartCol -> 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 <- getLayoutOffset+  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))++-- ---------------------------------------------------------------------++-- |non-destructive get+peekAnnFinal :: KeywordId -> EP (Maybe DeltaPos)+peekAnnFinal kw = do+  (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds)+  return r++countAnnsEP :: KeywordId -> EP Int+countAnnsEP an = length <$> peekAnnFinal an++-- ---------------------------------------------------------------------+-- Printing functions++printString :: String -> EP ()+printString str = do+  (l,c) <- gets epPos+  setPos (l, c + length str)+  tell (mempty {output = 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 = padUntil++printStringAt :: Pos -> String -> EP ()+printStringAt p str = printWhitespace p >> printString str
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.GHC.ExactPrint.Types   (@@ -9,8 +10,7 @@   , Span   , PosToken   , DeltaPos(..)-  , ColOffset,ColDelta,Col-  , LineChanged(..)+  , LayoutStartCol(..) , ColDelta(..)   , Annotation(..)   , combineAnns   , annNone@@ -19,19 +19,19 @@   , mkAnnKey   , AnnConName(..)   , annGetConstr-  , unConName    , ResTyGADTHook(..)    , getAnnotationEP   , getAndRemoveAnnotationEP +  , LayoutFlag(..)+   ) where -import Data.Data-import Data.Monoid+import Data.Data (Data, Typeable, toConstr) -import qualified GHC           as GHC+import qualified GHC import qualified Outputable    as GHC  import qualified Data.Map as Map@@ -57,51 +57,40 @@ type Pos = (Int,Int) type Span = (Pos,Pos) -data DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)-type ColOffset = Int -- ^ indentation point for a new line-type ColDelta  = Int -- ^ difference between two cols-type Col       = Int+newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) +-- | Marks the start column of a layout block.+newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }+  deriving (Eq, Show, Num)+-- | Marks the distance from the start of the layout block to the element.+newtype ColDelta  = ColDelta { getColDelta :: Int }+  deriving (Eq, Show, Num)+ annNone :: Annotation-annNone = Ann (DP (0,0)) LineSame 0 0 []+annNone = Ann (DP (0,0)) 0 []  combineAnns :: Annotation -> Annotation -> Annotation-combineAnns (Ann ed1 nl1 c1 dp1 dps1) (Ann _ed2 _nl2 _c2 _dp2 dps2)-  = Ann ed1 nl1 c1 dp1 (dps1 ++ dps2)--data LineChanged = LineSame | LineChanged-                 | KeepOffset -- ^ For use in AST editing-                 | LayoutLineSame | LayoutLineChanged -- experimental, may replace LineSame and LineChanged-                 deriving (Show,Eq,Typeable)+combineAnns (Ann ed1 c1 dps1) (Ann _ed2  _c2  dps2)+  = Ann ed1 c1 (dps1 ++ dps2)  data Annotation = Ann   {-    ann_entry_delta  :: !DeltaPos -- ^ Offset used to get to the start-                                  -- of the SrcSpan, during the-                                  -- annotatePC phase-  , ann_original_nl  :: !LineChanged -- ^ Did the original span start-                                     -- on a new line wrt to the prior-                                     -- one?-  , ann_original_col :: !Col      -- ^ Start of the SrcSpan, as used-                                  -- during the annotatePC phase-  , ann_delta        :: !ColOffset -- ^ Indentation level introduced-                                   -- by this SrcSpan, for other items-                                   -- at same layout level-  , anns             :: [(KeywordId, DeltaPos)] -- TODO:AZ change this to ann_dps+    annEntryDelta      :: !DeltaPos -- ^ Offset used to get to the start+                                    --    of the SrcSpan.+  , annDelta           :: !ColDelta -- ^ Offset from the start of the current layout+                                   --  block. This is used when moving onto new+                                   --  lines when layout rules must be obeyed.+  , annsDP             :: [(KeywordId, DeltaPos)]  -- ^ Annotations associated with this element.    } deriving (Typeable,Eq)  instance Show Annotation where-  show (Ann dp nl c d ans) = "(Ann (" ++ show dp ++ ") " ++ show nl ++ " " ++ show c ++ " " ++ show d ++ " " ++ show ans ++ ")"+  show (Ann dp c ans) = "(Ann (" ++ show dp ++ ") " ++ show c ++ " " ++ " " ++ show ans ++ ")"  instance Monoid Annotation where   mempty = annNone   mappend = combineAnns --instance Show GHC.RdrName where-  show n = "(a RdrName)"- type Anns = Map.Map AnnKey Annotation  -- | For every @Located a@, use the @SrcSpan@ and constructor name of@@ -114,26 +103,12 @@ mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a)  -- Holds the name of a constructor-data AnnConName = CN String+data AnnConName = CN { unConName :: String }                  deriving (Eq,Show,Ord)  annGetConstr :: (Data a) => a -> AnnConName annGetConstr a = CN (show $ toConstr a)-{--annGetConstr a = CN con-  where-    -- map all RdrName constuctors to the same field.-    con = case show $ toConstr a of-      "Unqual" -> "RdrName"-      "Qual"   -> "RdrName"-      "Orig"   -> "RdrName"-      "Exact"  -> "RdrName"-      s        -> s--} -unConName :: AnnConName -> String-unConName (CN s) = s- -- |We need our own version of keywordid to distinguish between a -- semi-colon appearing within an AST element and one separating AST -- elements in a list.@@ -150,6 +125,14 @@                                      -- potential AST edits.                deriving (Eq,Show,Ord) +data LayoutFlag = LayoutRules | NoLayoutRules deriving (Show, Eq)++instance Monoid LayoutFlag where+  mempty = NoLayoutRules+  LayoutRules `mappend` _ = LayoutRules+  _ `mappend` LayoutRules = LayoutRules+  _ `mappend` _           = NoLayoutRules+ -- ---------------------------------------------------------------------  instance GHC.Outputable KeywordId where@@ -182,14 +165,15 @@ -- ---------------------------------------------------------------------  getAnnotationEP :: (Data a) =>  GHC.Located a -> Anns -> Maybe Annotation-getAnnotationEP  (GHC.L ss a) anns = Map.lookup (AnnKey ss (annGetConstr a)) anns+getAnnotationEP  (GHC.L ss a) annotations =+  Map.lookup (AnnKey ss (annGetConstr a)) annotations  getAndRemoveAnnotationEP :: (Data a)                          => GHC.Located a -> Anns -> (Maybe Annotation,Anns)-getAndRemoveAnnotationEP (GHC.L ss a) anns+getAndRemoveAnnotationEP (GHC.L ss a) annotations  = let key = AnnKey ss (annGetConstr a) in-    case Map.lookup key anns of-         Nothing  -> (Nothing,anns)-         Just av -> (Just av,Map.delete key anns)+    case Map.lookup key annotations of+         Nothing  -> (Nothing, annotations)+         Just av -> (Just av, Map.delete key annotations)  -- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -1,2471 +1,275 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId-module Language.Haskell.GHC.ExactPrint.Utils-  (-    annotateLHsModule--  , srcSpanStartLine-  , srcSpanEndLine-  , srcSpanStartColumn-  , srcSpanEndColumn-  , getListSrcSpan-  , getLocalBindsSrcSpan--  , ss2span-  , ss2pos-  , ss2posEnd-  , span2ss-  , undelta-  , undeltaComment-  , isGoodDelta-  , rdrName2String-  , isSymbolRdrName--  , isListComp--  , showGhc-  , showAnnData---  -- * For tests-  , debug--  , runAP-  , AP-  , getSrcSpanAP, pushSrcSpanAP, popSrcSpanAP-  , getAnnotationAP-  , addAnnotationsAP--  , ghead-  , glast-  , gtail-  , gfromJust--  ) where--import Control.Monad.State-import Control.Monad.Writer-import Control.Applicative-import Control.Exception-import Data.Data-import Data.Generics-import Data.List--import Language.Haskell.GHC.ExactPrint.Types--import qualified Bag            as GHC-import qualified BasicTypes     as GHC-import qualified BooleanFormula as GHC-import qualified Class          as GHC-import qualified CoAxiom        as GHC-import qualified DynFlags       as GHC-import qualified FastString     as GHC-import qualified ForeignCall    as GHC-import qualified GHC            as GHC-import qualified Name           as GHC-import qualified NameSet        as GHC-import qualified Outputable     as GHC-import qualified RdrName        as GHC-import qualified SrcLoc         as GHC-import qualified Var            as GHC--import qualified OccName(occNameString)--import qualified Data.Map as Map--import Debug.Trace--debug :: c -> String -> c--- debug = flip trace-debug c _ = c---- ------------------------------------------------------------------------data APState = APState-             { -- | A stack to the root of the AST.-               apStack :: [StackItem]-             , priorEndPosition :: GHC.SrcSpan-               -- | Ordered list of comments still to be allocated-             , apComments :: [Comment]-               -- | isInfix for a FunBind-               -- AZ: Is this still needed?-             , e_is_infix :: Bool-               -- | The original GHC API Annotations-             , apAnns :: GHC.ApiAnns-             }--data StackItem = StackItem-               { -- | Current `SrcSpan`-                 curSrcSpan :: GHC.SrcSpan-                 -- | The offset required to get from the prior end point to the-                 -- start of the current SrcSpan. Accessed via `getEntryDP`-               , offset     :: DeltaPos-                 -- | Offsets for the elements annotated in this `SrcSpan`-               , annOffsets :: [(KeywordId, DeltaPos)]-               -- | Indicates whether the contents of this SrcSpan are-               -- subject to vertical alignment layout rules-               , curLayoutOn :: Bool-                 -- | The constructor name of the AST element, to-                 -- distinguish between nested elements that have the same-                 -- `SrcSpan` in the AST.-               , annConName :: AnnConName-               }--defaultAPState :: GHC.ApiAnns -> APState-defaultAPState ga =-  let cs = flattenedComments ga in-    APState-      { apStack = []-      , priorEndPosition = GHC.noSrcSpan-      , apComments = cs-      , e_is_infix = False -- ^ AZ: Is this still needed? isInfix for a FunBind-      , apAnns     = ga    -- $-      }---- | Type used in the AP Monad. The state variables maintain---    - the current SrcSpan and the constructor of the thing it encloses---      as a stack to the root of the AST as it is traversed,---    - the srcspan of the last thing annotated, to calculate delta's from---    - extra data needing to be stored in the monad---    - the annotations provided by GHC-type AP a = StateT APState (Writer [(AnnKey, Annotation)]) a--data Grouping = None | Primed GHC.SrcSpan | Active DeltaPos | Done DeltaPos-              deriving (Eq,Show)---runAP :: AP () -> GHC.ApiAnns -> Anns-runAP apf ga = Map.fromListWith combineAnns . snd . runWriter-                . flip execStateT (defaultAPState ga) $ apf---- `debug` ("runAP:cs=" ++ showGhc cs)----- -----------------------------------------------------------------------flattenedComments :: GHC.ApiAnns -> [Comment]-flattenedComments (_,cm) = map tokComment . GHC.sortLocated . concat $ Map.elems cm---- ---------------------------------------getSrcSpanAP :: AP GHC.SrcSpan-getSrcSpanAP = gets (curSrcSpan . ghead "getSrcSpanAP" . apStack)--getPriorSrcSpanAP :: AP GHC.SrcSpan-getPriorSrcSpanAP = gets (curSrcSpan . ghead "getPriorSrcSpanAP" . tail . apStack)--pushSrcSpanAP :: Data a => (GHC.Located a) -> DeltaPos -> AP ()-pushSrcSpanAP (GHC.L l a) edp =-  let newss = StackItem l edp [] False (annGetConstr a) in-  modify (\s -> s { apStack =  newss : (apStack s) })--popSrcSpanAP :: AP ()-popSrcSpanAP = modify (\s -> s { apStack = tail (apStack s) })--getEntryDP :: AP DeltaPos-getEntryDP = gets (offset . head . apStack)--getUnallocatedComments :: AP [Comment]-getUnallocatedComments = gets apComments--putUnallocatedComments :: [Comment] -> AP ()-putUnallocatedComments cs = modify (\s -> s { apComments = cs } )---- -----------------------------------------------------------------------adjustDeltaForOffsetM :: DeltaPos -> AP DeltaPos-adjustDeltaForOffsetM dp = do-  colOffset <- getCurrentColOffset-  return (adjustDeltaForOffset colOffset dp)--adjustDeltaForOffset :: Int -> DeltaPos -> DeltaPos-adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line-adjustDeltaForOffset  colOffset    (DP (l,c)) = DP (l,c - colOffset)---- ------------------------------------------------------------------------- | Get the current column offset-getCurrentColOffset :: AP ColOffset-getCurrentColOffset = srcSpanStartColumn <$> getSrcSpanAP---- |Get the difference between the current and the previous--- colOffsets, if they are on the same line-getCurrentDP :: AP (ColOffset,LineChanged)-getCurrentDP = do-  -- Note: the current col offsets are not needed here, any-  -- indentation should be fully nested in an AST element-  ss <- getSrcSpanAP-  ps <- getPriorSrcSpanAP-  layoutOn <- getLayoutOn-  {--  let r = if srcSpanStartLine ss == srcSpanStartLine ps-             then (srcSpanStartColumn ss - srcSpanStartColumn ps,LineSame)-             else (srcSpanStartColumn ss, LineChanged)-   -}-  let colOffset = if srcSpanStartLine ss == srcSpanStartLine ps-                    then srcSpanStartColumn ss - srcSpanStartColumn ps-                    else srcSpanStartColumn ss-  let r = case (layoutOn, srcSpanStartLine ss == srcSpanStartLine ps) of-             (True,  True) -> (colOffset, LayoutLineSame)-             (True, False) -> (colOffset, LayoutLineChanged)-             (False, True) -> (colOffset, LineSame)-             (False,False) -> (colOffset, LineChanged)-  return r-    `debug` ("getCurrentDP:layoutOn=" ++ show layoutOn)---- ------------------------------------------------------------------------- |Note: assumes the prior end SrcSpan stack is nonempty-getPriorEnd :: AP GHC.SrcSpan-getPriorEnd = gets priorEndPosition--setPriorEnd :: GHC.SrcSpan -> AP ()-setPriorEnd pe = modify (\s -> s { priorEndPosition = pe })---- ---------------------------------------getAnnotationAP :: GHC.AnnKeywordId -> AP [GHC.SrcSpan]-getAnnotationAP an = do-    ga <- gets apAnns-    ss <- getSrcSpanAP-    return $ GHC.getAnnotation ga ss an--getAndRemoveAnnotationAP :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP [GHC.SrcSpan]-getAndRemoveAnnotationAP sp an = do-    ga <- gets apAnns-    let (r,ga') = GHC.getAndRemoveAnnotation ga sp an-    r <$ modify (\s -> s { apAnns = ga' })---tokComment :: GHC.Located GHC.AnnotationComment -> Comment-tokComment t@(GHC.L lt _) = Comment (ss2span lt) (ghcCommentText t)---- ----------------------------------------- |Add some annotation to the currently active SrcSpan-addAnnotationsAP :: Annotation -> AP ()-addAnnotationsAP ann = do-    l <- gets apStack-    tell [((getAnnKey $ ghead "addAnnotationsAP" l),ann)]--getAnnKey :: StackItem -> AnnKey-getAnnKey StackItem {curSrcSpan, annConName} = AnnKey curSrcSpan annConName---- ---------------------------------------addAnnDeltaPos :: (GHC.SrcSpan,KeywordId) -> DeltaPos -> AP ()-addAnnDeltaPos (_s,kw) dp = do-  (st:sts) <- gets apStack-  modify (\s -> s { apStack = (manip st) : sts })-  where-    manip s = s { annOffsets = (kw, dp) : (annOffsets s) }---- ---------------------------------------getLayoutOn :: AP Bool-getLayoutOn = gets (curLayoutOn . ghead "getSrcSpanAP" . apStack)--setLayoutOn :: Bool -> AP ()-setLayoutOn layoutOn = do-  (st:sts) <- gets apStack-  modify (\s -> s { apStack = (manip st) : sts })-  where-    manip s = s { curLayoutOn = layoutOn }---- ---------------------------------------getKds :: AP [(KeywordId,DeltaPos)]-getKds = gets (reverse . annOffsets . head . apStack)---- ---------------------------------------setFunIsInfix :: Bool -> AP ()-setFunIsInfix e = modify (\s -> s {e_is_infix = e})--getFunIsInfix :: AP Bool-getFunIsInfix = gets e_is_infix---- ----------------------------------------- | Enter a new AST element. Maintain SrcSpan stack-enterAST :: Data a => GHC.Located a -> AP ()-enterAST lss = do-  return () `debug` ("enterAST entered for " ++ show (ss2span $ GHC.getLoc lss))-  -- return () `debug` ("enterAST:currentColOffset=" ++ show (DP (0,srcSpanStartColumn $ GHC.getLoc lss)))-  -- Calculate offset required to get to the start of the SrcSPan-  pe <- getPriorEnd-  let ss = (GHC.getLoc lss)-  let edp = deltaFromSrcSpans pe ss-  edp' <- adjustDeltaForOffsetM edp-  -- need to save edp', and put it in Annotation--  pushSrcSpanAP lss edp'--  return ()----- | Pop up the SrcSpan stack, capture the annotations-leaveAST :: AP ()-leaveAST = do-  -- Automatically add any trailing comma or semi-  addDeltaAnnotationAfter GHC.AnnComma-  ss <- getSrcSpanAP-  if ss2span ss == ((1,1),(1,1))-     then return ()-     else addDeltaAnnotationsOutside GHC.AnnSemi AnnSemiSep--  (dp,nl)  <- getCurrentDP-  edp <- getEntryDP-  kds <- getKds-  addAnnotationsAP (Ann edp nl (srcSpanStartColumn ss) dp kds)-    `debug` ("leaveAST:(ss,edp,dp,kds)=" ++ show (showGhc ss,edp,dp,kds,dp))-  popSrcSpanAP-  return () -- `debug` ("leaveAST:(ss,dp,priorEnd)=" ++ show (ss2span ss,dp,ss2span priorEnd))---- -----------------------------------------------------------------------class Data ast => AnnotateP ast where-  annotateP :: GHC.SrcSpan -> ast -> AP ()---- |First move to the given location, then call exactP-annotatePC :: (AnnotateP ast) => GHC.Located ast -> AP ()-annotatePC a = withLocated a annotateP--withLocated :: Data a => GHC.Located a -> (GHC.SrcSpan -> a -> AP ()) -> AP ()-withLocated a@(GHC.L l ast) action = do-  enterAST a `debug` ("annotatePC:entering " ++ showGhc l)-  action l ast-  leaveAST `debug` ("annotatePC:leaving " ++ showGhc (l))--annotateMaybe :: (AnnotateP ast) => Maybe (GHC.Located ast) -> AP ()-annotateMaybe Nothing    = return ()-annotateMaybe (Just ast) = annotatePC ast--annotateList :: (AnnotateP ast) => [GHC.Located ast] -> AP ()-annotateList xs = mapM_ annotatePC xs---- | Flag the item to be annotated as requiring layout.-annotateWithLayout :: AnnotateP ast => GHC.Located ast -> AP ()-annotateWithLayout a = do-  withLocated a (\l ast -> annotateP l ast >> setLayoutOn True)--annotateListWithLayout :: AnnotateP [GHC.Located ast] => GHC.SrcSpan -> [GHC.Located ast] -> AP ()-annotateListWithLayout l ls = do-  let ss = getListSrcSpan ls-  addAnnDeltaPos (l,AnnList ss) (DP (0,0))-  annotateWithLayout (GHC.L ss ls)---- -----------------------------------------------------------------------isGoodDelta :: DeltaPos -> Bool-isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0---- ------------------------------------------------------------------------- |Split the ordered list of comments into ones that occur prior to--- the given SrcSpan and the rest-allocatePriorComments :: [Comment] -> GHC.SrcSpan -> ([Comment],[Comment])-allocatePriorComments cs ss = partition isPrior cs-  where-    (start,_) = ss2span ss-    isPrior (Comment s _)  = (fst s) < start-      `debug` ("allocatePriorComments:(s,ss,cond)=" ++ showGhc (s,ss,(fst s) < start))---- -----------------------------------------------------------------------addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> AP ()-addAnnotationWorker ann pa = do-  if not (isPointSrcSpan pa)-    then do-      pe <- getPriorEnd-      ss <- getSrcSpanAP-      let p = deltaFromSrcSpans pe pa-      case (ann,isGoodDelta p) of-        (G GHC.AnnComma,False) -> return ()-        (G GHC.AnnSemi, False) -> return ()-        (G GHC.AnnOpen, False) -> return ()-        (G GHC.AnnClose,False) -> return ()-        _ -> do-          cs <- getUnallocatedComments-          let (allocated,cs') = allocatePriorComments cs pa-          putUnallocatedComments cs'-          return () `debug`("addAnnotationWorker:(ss,pa,allocated,cs)=" ++ showGhc (ss,pa,allocated,cs))-          mapM_ addDeltaComment allocated-          p' <- adjustDeltaForOffsetM p-          addAnnDeltaPos (ss,ann) p'-          setPriorEnd pa-              -- `debug` ("addDeltaAnnotationWorker:(ss,pe,pa,p,ann)=" ++ show (ss2span ss,ss2span pe,ss2span pa,p,ann))-    else do-      return ()-          -- `debug` ("addDeltaAnnotationWorker::point span:(ss,ma,ann)=" ++ show (ss2span pa,ann))---- -----------------------------------------------------------------------addDeltaComment :: Comment -> AP ()-addDeltaComment (Comment paspan str) = do-  let pa = span2ss paspan-  pe <- getPriorEnd-  ss <- getSrcSpanAP-  let p = deltaFromSrcSpans pe pa-  p' <- adjustDeltaForOffsetM p-  setPriorEnd pa-  let e = ss2deltaP (ss2posEnd pe) (snd paspan)-  e' <- adjustDeltaForOffsetM e-  addAnnDeltaPos (ss,AnnComment (DComment (p',e') str)) p'---- ------------------------------------------------------------------------- | Look up and add a Delta annotation at the current position, and--- advance the position to the end of the annotation-addDeltaAnnotation :: GHC.AnnKeywordId -> AP ()-addDeltaAnnotation ann = do-  ss <- getSrcSpanAP-  ma <- getAnnotationAP ann-  case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier-    [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show ann)-    [pa] -> addAnnotationWorker (G ann) pa-    _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma)---- | Look up and add a Delta annotation appearing beyond the current--- SrcSpan at the current position, and advance the position to the--- end of the annotation-addDeltaAnnotationAfter :: GHC.AnnKeywordId -> AP ()-addDeltaAnnotationAfter ann = do-  ss <- getSrcSpanAP-  ma <- getAnnotationAP ann-  let ma' = filter (\s -> not (GHC.isSubspanOf s ss)) ma-  case ma' of-    [] -> return () `debug` ("addDeltaAnnotation empty ma")-    [pa] -> addAnnotationWorker (G ann) pa-    _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma)---- | Look up and add a Delta annotation at the current position, and--- advance the position to the end of the annotation-addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> AP ()-addDeltaAnnotationLs ann off = do-  ma <- getAnnotationAP ann-  case (drop off ma) of-    [] -> return ()-        -- `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma))-    (pa:_) -> addAnnotationWorker (G ann) pa---- | Look up and add possibly multiple Delta annotation at the current--- position, and advance the position to the end of the annotations-addDeltaAnnotations :: GHC.AnnKeywordId -> AP ()-addDeltaAnnotations ann = do-  ma <- getAnnotationAP ann-  let do_one ap' = addAnnotationWorker (G ann) ap'-                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))-  mapM_ do_one (sort ma)---- | Look up and add possibly multiple Delta annotations enclosed by--- the current SrcSpan at the current position, and advance the--- position to the end of the annotations-addDeltaAnnotationsInside :: GHC.AnnKeywordId -> AP ()-addDeltaAnnotationsInside ann = do-  ss <- getSrcSpanAP-  ma <- getAnnotationAP ann-  let do_one ap' = addAnnotationWorker (G ann) ap'-                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))-  mapM_ do_one (sort $ filter (\s -> GHC.isSubspanOf s ss) ma)---- | Look up and add possibly multiple Delta annotations not enclosed by--- the current SrcSpan at the current position, and advance the--- position to the end of the annotations-addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> AP ()-addDeltaAnnotationsOutside gann ann = do-  ss <- getSrcSpanAP-  -- ma <- getAnnotationAP ss gann-  ma <- getAndRemoveAnnotationAP ss gann-  let do_one ap' = addAnnotationWorker ann ap'-                    -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))-  mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma)---- | Add a Delta annotation at the current position, and advance the--- position to the end of the annotation-addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP ()-addDeltaAnnotationExt s ann = do-  addAnnotationWorker (G ann) s---addEofAnnotation :: AP ()-addEofAnnotation = do-  pe <- getPriorEnd-  ss <- getSrcSpanAP-  pushSrcSpanAP (GHC.noLoc ()) (DP (0,0))-  ma <- getAnnotationAP GHC.AnnEofPos-  popSrcSpanAP-  case ma of-    [] -> return ()-    [pa] -> do-      cs <- getUnallocatedComments-      mapM_ addDeltaComment cs-      let DP (r,c) = deltaFromSrcSpans pe pa-      addAnnDeltaPos (ss,G GHC.AnnEofPos) (DP (r, c - 1))-      setPriorEnd pa--countAnnsAP :: GHC.AnnKeywordId -> AP Int-countAnnsAP ann = do-  ma <- getAnnotationAP ann-  return (length ma)---- ------------------------------------------------------------------------ Managing lists which have been separated, e.g. Sigs and Binds--prepareListAnnotation :: AnnotateP a => [GHC.Located a] -> [(GHC.SrcSpan,AP ())]-prepareListAnnotation ls = map (\b@(GHC.L l _) -> (l,annotatePC b)) ls--applyListAnnotations :: [(GHC.SrcSpan,AP ())] -> AP ()-applyListAnnotations ls-  = mapM_ (\(_,b) -> b) $ sortBy (\(a,_) (b,_) -> compare a b) ls---- ------------------------------------------------------------------------ Start of application specific part---- -----------------------------------------------------------------------annotateLHsModule :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns-                  -> Anns-annotateLHsModule modu ghcAnns-   = runAP (pushSrcSpanAP (GHC.L GHC.noSrcSpan ()) (DP (0,0)) >> annotatePC modu) ghcAnns---- -----------------------------------------------------------------------instance AnnotateP (GHC.HsModule GHC.RdrName) where-  annotateP lm (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do-    setPriorEnd lm--    addDeltaAnnotation GHC.AnnModule--    case mmn of-      Nothing -> return ()-      Just (GHC.L ln _) -> addDeltaAnnotationExt ln GHC.AnnVal--    annotateMaybe mdepr--    case mexp of-      Nothing   -> return ()-      Just expr -> annotatePC expr--    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC -- Possible '{'-    addDeltaAnnotations GHC.AnnSemi -- possible leading semis-    mapM_ annotatePC imps--    annotateList decs--    addDeltaAnnotation GHC.AnnCloseC -- Possible '}'--    addEofAnnotation----- -----------------------------------------------------------------------instance AnnotateP GHC.WarningTxt where-  annotateP _ (GHC.WarningTxt (GHC.L ls _) lss) = do-    addDeltaAnnotationExt ls GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenS-    mapM_ annotatePC lss-    addDeltaAnnotation GHC.AnnCloseS-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.DeprecatedTxt (GHC.L ls _) lss) = do-    addDeltaAnnotationExt ls GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenS-    mapM_ annotatePC lss-    addDeltaAnnotation GHC.AnnCloseS-    addDeltaAnnotation GHC.AnnClose---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name)-  => AnnotateP [GHC.LIE name] where-   annotateP _ ls = do-     addDeltaAnnotation GHC.AnnHiding -- in an import decl-     addDeltaAnnotation GHC.AnnOpenP -- '('-     mapM_ annotatePC ls-     addDeltaAnnotation GHC.AnnCloseP -- ')'--instance (GHC.DataId name,AnnotateP name)-  => AnnotateP (GHC.IE name) where-  annotateP _ ie = do--    case ie of-        (GHC.IEVar ln) -> do-          addDeltaAnnotation GHC.AnnPattern-          addDeltaAnnotation GHC.AnnType-          annotatePC ln--        (GHC.IEThingAbs ln) -> do-          addDeltaAnnotation GHC.AnnType-          annotatePC ln--        (GHC.IEThingWith ln ns) -> do-          annotatePC ln-          addDeltaAnnotation GHC.AnnOpenP-          mapM_ annotatePC ns-          addDeltaAnnotation GHC.AnnCloseP--        (GHC.IEThingAll ln) -> do-          annotatePC ln-          addDeltaAnnotation GHC.AnnOpenP-          addDeltaAnnotation GHC.AnnDotdot-          addDeltaAnnotation GHC.AnnCloseP--        (GHC.IEModuleContents (GHC.L lm _n)) -> do-          addDeltaAnnotation GHC.AnnModule-          addDeltaAnnotationExt lm GHC.AnnVal----- -----------------------------------------------------------------------instance AnnotateP GHC.RdrName where-  annotateP l n = do-    case rdrName2String n of-      "[]" -> do-        addDeltaAnnotation GHC.AnnOpenS  -- '['-        addDeltaAnnotation GHC.AnnCloseS -- ']'-      "()" -> do-        addDeltaAnnotation GHC.AnnOpenP  -- '('-        addDeltaAnnotation GHC.AnnCloseP -- ')'-      "(##)" -> do-        addDeltaAnnotation GHC.AnnOpen  -- '(#'-        addDeltaAnnotation GHC.AnnClose -- '#)'-      "[::]" -> do-        addDeltaAnnotation GHC.AnnOpen  -- '[:'-        addDeltaAnnotation GHC.AnnClose -- ':]'-      _ ->  do-        addDeltaAnnotation GHC.AnnType-        addDeltaAnnotation GHC.AnnOpenP -- '('-        addDeltaAnnotationLs GHC.AnnBackquote 0-        addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)'-        cnt <- countAnnsAP GHC.AnnVal-        cntT <- countAnnsAP GHC.AnnCommaTuple-        cntR <- countAnnsAP GHC.AnnRarrow-        case cnt of-          0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal-          1 -> addDeltaAnnotation GHC.AnnVal-          x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x)-        addDeltaAnnotation GHC.AnnTildehsh-        addDeltaAnnotation GHC.AnnTilde-        addDeltaAnnotation GHC.AnnRarrow-        addDeltaAnnotationLs GHC.AnnBackquote 1-        addDeltaAnnotation GHC.AnnCloseP -- ')'---- -----------------------------------------------------------------------instance AnnotateP GHC.Name where-  annotateP l _n = do-    addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name)-  => AnnotateP (GHC.ImportDecl name) where- annotateP _ (GHC.ImportDecl _msrc (GHC.L ln _) _pkg _src _safe _qual _impl _as hiding) = do--   -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec-   addDeltaAnnotation GHC.AnnImport--   -- "{-# SOURCE" and "#-}"-   addDeltaAnnotation GHC.AnnOpen-   addDeltaAnnotation GHC.AnnClose-   addDeltaAnnotation GHC.AnnSafe-   addDeltaAnnotation GHC.AnnQualified-   addDeltaAnnotation GHC.AnnPackageName--   addDeltaAnnotationExt ln GHC.AnnVal -- modid--   addDeltaAnnotation GHC.AnnAs-   addDeltaAnnotation GHC.AnnVal -- as modid--   case hiding of-     Nothing -> return ()-     Just (_isHiding,lie) -> do-       addDeltaAnnotation GHC.AnnHiding-       annotatePC lie---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.HsDecl name) where-  annotateP l decl = do-    case decl of-      GHC.TyClD d       -> annotateP l d-      GHC.InstD d       -> annotateP l d-      GHC.DerivD d      -> annotateP l d-      GHC.ValD d        -> annotateP l d-      GHC.SigD d        -> annotateP l d-      GHC.DefD d        -> annotateP l d-      GHC.ForD d        -> annotateP l d-      GHC.WarningD d    -> annotateP l d-      GHC.AnnD d        -> annotateP l d-      GHC.RuleD d       -> annotateP l d-      GHC.VectD d       -> annotateP l d-      GHC.SpliceD d     -> annotateP l d-      GHC.DocD d        -> annotateP l d-      GHC.QuasiQuoteD d -> annotateP l d-      GHC.RoleAnnotD d  -> annotateP l d---- -----------------------------------------------------------------------instance (AnnotateP name)-   => AnnotateP (GHC.RoleAnnotDecl name) where-  annotateP _ (GHC.RoleAnnotDecl ln mr) = do-    addDeltaAnnotation GHC.AnnType-    addDeltaAnnotation GHC.AnnRole-    annotatePC ln-    mapM_ annotatePC mr--instance AnnotateP (Maybe GHC.Role) where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (AnnotateP name)-   => AnnotateP (GHC.HsQuasiQuote name) where-  annotateP _ (GHC.HsQuasiQuote _n _ss _fs) = assert False undefined---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.SpliceDecl name) where-  annotateP _ (GHC.SpliceDecl (GHC.L _ls (GHC.HsSplice _n e)) _flag) = do-    addDeltaAnnotation GHC.AnnOpen -- "$(" or "$$("-    annotatePC e-    addDeltaAnnotation GHC.AnnClose -- ")"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.VectDecl name) where-  annotateP _ (GHC.HsVect _src ln e) = do-    addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE"-    annotatePC ln-    addDeltaAnnotation GHC.AnnEqual-    annotatePC e-    addDeltaAnnotation GHC.AnnClose -- "#-}"--  annotateP _ (GHC.HsNoVect _src ln) = do-    addDeltaAnnotation GHC.AnnOpen -- "{-# NOVECTORISE"-    annotatePC ln-    addDeltaAnnotation GHC.AnnClose -- "#-}"--  annotateP _ (GHC.HsVectTypeIn _src _b ln mln) = do-    addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE" or "{-# VECTORISE SCALAR"-    addDeltaAnnotation GHC.AnnType-    annotatePC ln-    addDeltaAnnotation GHC.AnnEqual-    annotateMaybe mln-    addDeltaAnnotation GHC.AnnClose -- "#-}"--  annotateP _ (GHC.HsVectTypeOut {}) = error $ "annotateP.HsVectTypeOut: only valid after type checker"--  annotateP _ (GHC.HsVectClassIn _src ln) = do-    addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE"-    addDeltaAnnotation GHC.AnnClass-    annotatePC ln-    addDeltaAnnotation GHC.AnnClose -- "#-}"--  annotateP _ (GHC.HsVectClassOut {}) = error $ "annotateP.HsVectClassOut: only valid after type checker"-  annotateP _ (GHC.HsVectInstIn {})   = error $ "annotateP.HsVectInstIn: not supported?"-  annotateP _ (GHC.HsVectInstOut {})   = error $ "annotateP.HsVectInstOut: not supported?"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.RuleDecls name) where-   annotateP _ (GHC.HsRules _src rules) = do-     addDeltaAnnotation GHC.AnnOpen-     mapM_ annotatePC rules-     addDeltaAnnotation GHC.AnnClose---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.RuleDecl name) where-  annotateP _ (GHC.HsRule ln _act bndrs lhs _ rhs _) = do-    annotatePC ln-    -- activation-    addDeltaAnnotation GHC.AnnOpenS -- "["-    addDeltaAnnotation GHC.AnnTilde-    addDeltaAnnotation GHC.AnnVal-    addDeltaAnnotation GHC.AnnCloseS -- "]"--    addDeltaAnnotation GHC.AnnForall-    mapM_ annotatePC bndrs-    addDeltaAnnotation GHC.AnnDot--    annotatePC lhs-    addDeltaAnnotation GHC.AnnEqual-    annotatePC rhs---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.RuleBndr name) where-  annotateP _ (GHC.RuleBndr ln) = annotatePC ln-  annotateP _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do-    addDeltaAnnotation GHC.AnnOpenP -- "("-    annotatePC ln-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC thing-    addDeltaAnnotation GHC.AnnCloseP -- ")"---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.AnnDecl name) where-   annotateP _ (GHC.HsAnnotation _src prov e) = do-     addDeltaAnnotation GHC.AnnOpen -- "{-# Ann"-     addDeltaAnnotation GHC.AnnType-     addDeltaAnnotation GHC.AnnModule-     case prov of-       (GHC.ValueAnnProvenance n) -> annotatePC n-       (GHC.TypeAnnProvenance n) -> annotatePC n-       (GHC.ModuleAnnProvenance) -> return ()--     annotatePC e-     addDeltaAnnotation GHC.AnnClose---- -----------------------------------------------------------------------instance AnnotateP name => AnnotateP (GHC.WarnDecls name) where-   annotateP _ (GHC.Warnings _src warns) = do-     addDeltaAnnotation GHC.AnnOpen-     mapM_ annotatePC warns-     addDeltaAnnotation GHC.AnnClose---- -----------------------------------------------------------------------instance (AnnotateP name)-   => AnnotateP (GHC.WarnDecl name) where-   annotateP _ (GHC.Warning lns txt) = do-     mapM_ annotatePC lns-     addDeltaAnnotation GHC.AnnOpenS -- "["-     case txt of-       GHC.WarningTxt    _src ls -> mapM_ annotatePC ls-       GHC.DeprecatedTxt _src ls -> mapM_ annotatePC ls-     addDeltaAnnotation GHC.AnnCloseS -- "]"--instance AnnotateP GHC.FastString where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.ForeignDecl name) where--  annotateP _ (GHC.ForeignImport ln typ _-               (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls _src))) = do-    addDeltaAnnotation GHC.AnnForeign-    addDeltaAnnotation GHC.AnnImport-    annotatePC cconv-    if ll == GHC.noSrcSpan-      then return ()-      else annotatePC safety-    -- annotateMaybe mh-    addDeltaAnnotationExt ls GHC.AnnVal-    annotatePC ln-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ---  annotateP _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls _src))) = do-    addDeltaAnnotation GHC.AnnForeign-    addDeltaAnnotation GHC.AnnExport-    annotatePC spec-    addDeltaAnnotationExt ls GHC.AnnVal-    annotatePC ln-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ----- -----------------------------------------------------------------------instance (AnnotateP GHC.CExportSpec) where-  annotateP l (GHC.CExportStatic _ cconv) = annotateP l cconv---- -----------------------------------------------------------------------instance (AnnotateP GHC.CCallConv) where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (AnnotateP GHC.Safety) where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.DerivDecl name) where--  annotateP _ (GHC.DerivDecl typ mov) = do-    addDeltaAnnotation GHC.AnnDeriving-    addDeltaAnnotation GHC.AnnInstance-    annotateMaybe mov-    annotatePC typ---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.DefaultDecl name) where--  annotateP _ (GHC.DefaultDecl typs) = do-    addDeltaAnnotation GHC.AnnDefault-    addDeltaAnnotation GHC.AnnOpenP -- '('-    mapM_ annotatePC typs-    addDeltaAnnotation GHC.AnnCloseP -- ')'---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.InstDecl name) where--  annotateP l (GHC.ClsInstD      cid) = annotateP l  cid-  annotateP l (GHC.DataFamInstD dfid) = annotateP l dfid-  annotateP l (GHC.TyFamInstD   tfid) = annotateP l tfid---- -----------------------------------------------------------------------instance AnnotateP (GHC.OverlapMode) where-  annotateP _ _ = do-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnClose---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.ClsInstDecl name) where--  annotateP _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do-    addDeltaAnnotation GHC.AnnInstance-    annotateMaybe mov-    annotatePC poly-    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC -- '{'-    addDeltaAnnotationsInside GHC.AnnSemi--    -- AZ:Need to turn this into a located list annotation.-    -- must merge all the rest-    applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)-                       ++ prepareListAnnotation sigs-                       ++ prepareListAnnotation tyfams-                       ++ prepareListAnnotation datafams-                         )--    addDeltaAnnotation GHC.AnnCloseC -- '}'---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.TyFamInstDecl name) where--  annotateP _ (GHC.TyFamInstDecl eqn _) = do-    addDeltaAnnotation GHC.AnnType-    addDeltaAnnotation GHC.AnnInstance-    annotatePC eqn---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.DataFamInstDecl name) where--  annotateP l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do-    addDeltaAnnotation GHC.AnnData-    addDeltaAnnotation GHC.AnnNewtype-    addDeltaAnnotation GHC.AnnInstance-    annotatePC ln-    mapM_ annotatePC pats-    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnEqual-    annotateDataDefn l defn---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) =>-                                                  AnnotateP (GHC.HsBind name) where-  annotateP _ (GHC.FunBind (GHC.L _ln _n) isInfix (GHC.MG matches _ _ _) _ _ _) = do-    setFunIsInfix isInfix-    mapM_ annotatePC matches--  annotateP _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do-    annotatePC lhs-    addDeltaAnnotation GHC.AnnEqual-    mapM_ annotatePC grhs-    addDeltaAnnotation GHC.AnnWhere--    -- TODO: Store the following SrcSpan in an AnnList instance for exactPC-    annotatePC (GHC.L (getLocalBindsSrcSpan lb) lb)--  annotateP _ (GHC.VarBind _n rhse _) =-    -- Note: this bind is introduced by the typechecker-    annotatePC rhse--  annotateP l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do-    addDeltaAnnotation GHC.AnnPattern-    annotatePC ln-    case args of-      GHC.InfixPatSyn la lb -> do-        annotatePC la-        annotatePC lb-      GHC.PrefixPatSyn ns -> do-        mapM_ annotatePC ns-    addDeltaAnnotation GHC.AnnEqual-    addDeltaAnnotation GHC.AnnLarrow-    annotatePC def-    case dir of-      GHC.Unidirectional           -> return ()-      GHC.ImplicitBidirectional    -> return ()-      GHC.ExplicitBidirectional mg -> annotateMatchGroup l mg--    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC  -- '{'-    addDeltaAnnotation GHC.AnnCloseC -- '}'--    return ()---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-    => AnnotateP (GHC.IPBind name) where-  annotateP _ (GHC.IPBind en e) = do-    case en of-      Left n -> annotatePC n-      Right _i -> error $ "annotateP.IPBind:should not happen"-    addDeltaAnnotation GHC.AnnEqual-    annotatePC e---- -----------------------------------------------------------------------instance AnnotateP GHC.HsIPName where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,-                                                  AnnotateP body)-  => AnnotateP (GHC.Match name (GHC.Located body)) where--  annotateP _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do-    isInfix <- getFunIsInfix-    let-      get_infix Nothing = isInfix-      get_infix (Just (_,f)) = f-    case (get_infix mln,pats) of-      (True,[a,b]) -> do-        annotatePC a-        case mln of-          Nothing -> do-            addDeltaAnnotation GHC.AnnOpen -- possible '`'-            addDeltaAnnotation GHC.AnnFunId-            addDeltaAnnotation GHC.AnnClose -- possible '`'-          Just (n,_) -> annotatePC n-        annotatePC b-      _ -> do-        case mln of-          Nothing -> addDeltaAnnotation GHC.AnnFunId-          Just (n,_) -> annotatePC n-        mapM_ annotatePC pats--    addDeltaAnnotation GHC.AnnEqual-    addDeltaAnnotation GHC.AnnRarrow -- For HsLam--    mapM_ annotatePC grhs--    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC -- '{'-    addDeltaAnnotationsInside GHC.AnnSemi-    -- annotateHsLocalBinds lb-    annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)-    addDeltaAnnotation GHC.AnnCloseC -- '}'---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,-                                                  AnnotateP body)-  => AnnotateP (GHC.GRHS name (GHC.Located body)) where-  annotateP _ (GHC.GRHS guards expr) = do--    addDeltaAnnotation GHC.AnnVbar-    mapM_ annotatePC guards-    addDeltaAnnotation GHC.AnnEqual-    addDeltaAnnotation GHC.AnnRarrow -- in case alts-    annotatePC expr---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.Sig name) where--  annotateP _ (GHC.TypeSig lns typ _) = do-    mapM_ annotatePC lns-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ--  annotateP _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do-    addDeltaAnnotation GHC.AnnPattern-    annotatePC ln-    addDeltaAnnotation GHC.AnnDcolon--    -- Note: The 'forall' bndrs '.' may occur multiple times-    addDeltaAnnotation GHC.AnnForall-    mapM_ annotatePC bndrs-    addDeltaAnnotation GHC.AnnDot--    annotatePC ctx1-    addDeltaAnnotationLs GHC.AnnDarrow 0-    annotatePC ctx2-    addDeltaAnnotationLs GHC.AnnDarrow 1-    annotatePC typ---  annotateP _ (GHC.GenericSig ns typ) = do-    addDeltaAnnotation GHC.AnnDefault-    mapM_ annotatePC ns-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ--  annotateP _ (GHC.IdSig _) = return ()--  -- FixSig (FixitySig name)-  annotateP _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity _v _fdir))) = do-    addDeltaAnnotation GHC.AnnInfix-    addDeltaAnnotation GHC.AnnVal-    mapM_ annotatePC lns--  -- InlineSig (Located name) InlinePragma-  -- '{-# INLINE' activation qvar '#-}'-  annotateP _ (GHC.InlineSig ln _inl) = do-    addDeltaAnnotation GHC.AnnOpen   -- '{-# INLINE'-    addDeltaAnnotation GHC.AnnOpenS  -- '['-    addDeltaAnnotation  GHC.AnnTilde -- ~-    addDeltaAnnotation  GHC.AnnVal   -- e.g. 34-    addDeltaAnnotation GHC.AnnCloseS -- ']'-    annotatePC ln-    addDeltaAnnotation GHC.AnnClose -- '#-}'---  annotateP _ (GHC.SpecSig ln typs _inl) = do-    addDeltaAnnotation GHC.AnnOpen  -- '{-# SPECIALISE'-    addDeltaAnnotation GHC.AnnOpenS --  '['-    addDeltaAnnotation GHC.AnnTilde -- ~-    addDeltaAnnotation GHC.AnnVal   -- e.g. 34--    addDeltaAnnotation GHC.AnnCloseS -- ']'-    annotatePC ln-    addDeltaAnnotation GHC.AnnDcolon -- '::'-    mapM_ annotatePC typs-    addDeltaAnnotation GHC.AnnClose -- '#-}'---  -- '{-# SPECIALISE' 'instance' inst_type '#-}'-  annotateP _ (GHC.SpecInstSig _ typ) = do-    addDeltaAnnotation GHC.AnnOpen -- '{-# SPECIALISE'-    addDeltaAnnotation GHC.AnnInstance-    annotatePC typ-    addDeltaAnnotation GHC.AnnClose -- '#-}'---  -- MinimalSig (BooleanFormula (Located name))-  annotateP _ (GHC.MinimalSig _ formula) = do-    addDeltaAnnotation GHC.AnnOpen -- '{-# MINIMAL'-    annotateBooleanFormula formula-    addDeltaAnnotation GHC.AnnClose -- '#-}'----- -----------------------------------------------------------------------annotateBooleanFormula :: GHC.BooleanFormula (GHC.Located name) -> AP ()-annotateBooleanFormula = assert False undefined---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) =>-                     AnnotateP (GHC.HsTyVarBndr name) where-  annotateP l (GHC.UserTyVar _n) = do-    addDeltaAnnotationExt l GHC.AnnVal--  annotateP _ (GHC.KindedTyVar n ty) = do-    addDeltaAnnotation GHC.AnnOpenP  -- '('-    annotatePC n-    addDeltaAnnotation GHC.AnnDcolon -- '::'-    annotatePC ty-    addDeltaAnnotation GHC.AnnCloseP -- '('---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.HsType name) where--  annotateP _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do-    addDeltaAnnotation GHC.AnnOpenP -- "("-    addDeltaAnnotation GHC.AnnForall-    mapM_ annotatePC tvs-    addDeltaAnnotation GHC.AnnDot--    case mwc of-      Nothing -> if lc /= GHC.noSrcSpan then annotatePC ctx else return ()-      Just lwc -> annotatePC (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs)))--    addDeltaAnnotation GHC.AnnDarrow-    annotatePC typ-    addDeltaAnnotation GHC.AnnCloseP -- ")"--  annotateP l (GHC.HsTyVar n) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    annotateP l n--  annotateP _ (GHC.HsAppTy t1 t2) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    annotatePC t1-    annotatePC t2--  annotateP _ (GHC.HsFunTy t1 t2) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    annotatePC t1-    addDeltaAnnotation GHC.AnnRarrow-    annotatePC t2--  annotateP _ (GHC.HsListTy t) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    addDeltaAnnotation GHC.AnnOpenS -- '['-    annotatePC t-    addDeltaAnnotation GHC.AnnCloseS -- ']'--  annotateP _ (GHC.HsPArrTy t) = do-    addDeltaAnnotation GHC.AnnOpen  -- '[:'-    annotatePC t-    addDeltaAnnotation GHC.AnnClose -- ':]'--  annotateP _ (GHC.HsTupleTy _tt ts) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    addDeltaAnnotation GHC.AnnOpen  -- '(#'-    addDeltaAnnotation GHC.AnnOpenP  -- '('-    mapM_ annotatePC ts-    addDeltaAnnotation GHC.AnnCloseP -- ')'-    addDeltaAnnotation GHC.AnnClose --  '#)'--  annotateP _ (GHC.HsOpTy t1 (_,lo) t2) = do-    annotatePC t1-    annotatePC lo-    annotatePC t2--  annotateP _ (GHC.HsParTy t) = do-    addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType-    addDeltaAnnotation GHC.AnnOpenP  -- '('-    annotatePC t-    addDeltaAnnotation GHC.AnnCloseP -- ')'--  annotateP _ (GHC.HsIParamTy _n t) = do-    addDeltaAnnotation GHC.AnnVal-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC t--  annotateP _ (GHC.HsEqTy t1 t2) = do-    annotatePC t1-    addDeltaAnnotation GHC.AnnTilde-    annotatePC t2--  annotateP _ (GHC.HsKindSig t k) = do-    addDeltaAnnotation GHC.AnnOpenP  -- '('-    annotatePC t-    addDeltaAnnotation GHC.AnnDcolon -- '::'-    annotatePC k-    addDeltaAnnotation GHC.AnnCloseP -- ')'--  -- HsQuasiQuoteTy (HsQuasiQuote name)-  annotateP l (GHC.HsQuasiQuoteTy _qq) = do-    addDeltaAnnotationExt l GHC.AnnVal--  -- HsSpliceTy (HsSplice name) (PostTc name Kind)-  annotateP _ (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do-    addDeltaAnnotation GHC.AnnOpen  -- '$('-    annotatePC e-    addDeltaAnnotation GHC.AnnClose -- ')'--  annotateP _ (GHC.HsDocTy t ds) = do-    annotatePC t-    annotatePC ds--  annotateP _ (GHC.HsBangTy _b t) = do-    addDeltaAnnotation GHC.AnnOpen  -- '{-# UNPACK' or '{-# NOUNPACK'-    addDeltaAnnotation GHC.AnnClose -- '#-}'-    addDeltaAnnotation GHC.AnnBang  -- '!'-    annotatePC t--  -- HsRecTy [LConDeclField name]-  annotateP _ (GHC.HsRecTy cons) = do-    addDeltaAnnotation GHC.AnnOpenC  -- '{'-    mapM_ annotatePC cons-    addDeltaAnnotation GHC.AnnCloseC -- '}'--  -- HsCoreTy Type-  annotateP _ (GHC.HsCoreTy _t) = return ()--  annotateP _ (GHC.HsExplicitListTy _ ts) = do-    -- TODO: what about SIMPLEQUOTE?-    addDeltaAnnotation GHC.AnnOpen  -- "'["-    mapM_ annotatePC ts-    addDeltaAnnotation GHC.AnnCloseS -- ']'--  annotateP _ (GHC.HsExplicitTupleTy _ ts) = do-    addDeltaAnnotation GHC.AnnOpen  -- "'("-    mapM_ annotatePC ts-    addDeltaAnnotation GHC.AnnClose -- ')'--  -- HsTyLit HsTyLit-  annotateP l (GHC.HsTyLit _tl) = do-    addDeltaAnnotationExt l GHC.AnnVal--  -- HsWrapTy HsTyWrapper (HsType name)-  annotateP _ (GHC.HsWrapTy _ _) = return ()--  annotateP l (GHC.HsWildcardTy) = do-    addDeltaAnnotationExt l GHC.AnnVal-    addDeltaAnnotation GHC.AnnDarrow -- if only part of a partial type signature context--  annotateP l (GHC.HsNamedWildcardTy _n) = do-    addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) =>-                             AnnotateP (GHC.ConDeclField name) where-  annotateP _ (GHC.ConDeclField ns ty mdoc) = do-    mapM_ annotatePC ns-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC ty-    annotateMaybe mdoc---- -----------------------------------------------------------------------instance AnnotateP GHC.HsDocString where-  annotateP l (GHC.HsDocString _s) = do-    addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name)-  => AnnotateP (GHC.Pat name) where-  annotateP l (GHC.WildPat _) = addDeltaAnnotationExt l GHC.AnnVal-  annotateP l (GHC.VarPat _)  = addDeltaAnnotationExt l GHC.AnnVal-  annotateP _ (GHC.LazyPat p) = do-    addDeltaAnnotation GHC.AnnTilde-    annotatePC p--  annotateP _ (GHC.AsPat ln p) = do-    annotatePC ln-    addDeltaAnnotation GHC.AnnAt-    annotatePC p--  annotateP _ (GHC.ParPat p) = do-    addDeltaAnnotation GHC.AnnOpenP-    annotatePC p-    addDeltaAnnotation GHC.AnnCloseP--  annotateP _ (GHC.BangPat p) = do-    addDeltaAnnotation GHC.AnnBang-    annotatePC p--  annotateP _ (GHC.ListPat ps _ _) = do-    addDeltaAnnotation GHC.AnnOpenS-    mapM_ annotatePC ps-    addDeltaAnnotation GHC.AnnCloseS--  annotateP _ (GHC.TuplePat ps _ _) = do-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenP-    mapM_ annotatePC ps-    addDeltaAnnotation GHC.AnnCloseP-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.PArrPat ps _) = do-    addDeltaAnnotation GHC.AnnOpen-    mapM_ annotatePC ps-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.ConPatIn n dets) = do-    annotateHsConPatDetails n dets--  annotateP _ (GHC.ConPatOut {}) = return ()--  -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type)-  annotateP _ (GHC.ViewPat e pat _) = do-    annotatePC e-    addDeltaAnnotation GHC.AnnRarrow-    annotatePC pat--  -- SplicePat (HsSplice id)-  annotateP _ (GHC.SplicePat (GHC.HsSplice _ e)) = do-    addDeltaAnnotation GHC.AnnOpen -- '$('-    annotatePC e-    addDeltaAnnotation GHC.AnnClose -- ')'--  -- QuasiQuotePat (HsQuasiQuote id)-  annotateP l (GHC.QuasiQuotePat (GHC.HsQuasiQuote _ _ _)) = do-    addDeltaAnnotationExt l GHC.AnnVal--  -- LitPat HsLit-  annotateP l (GHC.LitPat _lp) = addDeltaAnnotationExt l GHC.AnnVal--  -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id)-  annotateP _ (GHC.NPat ol _ _) = do-    addDeltaAnnotation GHC.AnnMinus-    annotatePC ol--  -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id)-  annotateP _ (GHC.NPlusKPat ln ol _ _) = do-    annotatePC ln-    addDeltaAnnotation GHC.AnnVal -- "+"-    annotatePC ol--  annotateP l (GHC.SigPatIn pat ty) = do-    annotatePC pat-    addDeltaAnnotation GHC.AnnDcolon-    annotateP l ty--  annotateP _ (GHC.SigPatOut {}) = return ()--  -- CoPat HsWrapper (Pat id) Type-  annotateP _ (GHC.CoPat {}) = return ()---- -----------------------------------------------------------------------annotateHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-                      => GHC.Located name -> GHC.HsConPatDetails name -> AP ()-annotateHsConPatDetails ln dets = do-  case dets of-    GHC.PrefixCon args -> do-      annotatePC ln-      mapM_ annotatePC args-    GHC.RecCon (GHC.HsRecFields fs _) -> do-      annotatePC ln-      addDeltaAnnotation GHC.AnnOpenC -- '{'-      mapM_ annotatePC fs-      addDeltaAnnotation GHC.AnnDotdot-      addDeltaAnnotation GHC.AnnCloseC -- '}'-    GHC.InfixCon a1 a2 -> do-      annotatePC a1-      annotatePC ln-      annotatePC a2--annotateHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-                    =>  [GHC.Located name] -> GHC.HsConDeclDetails name -> AP ()-annotateHsConDeclDetails lns dets = do-  case dets of-    GHC.PrefixCon args -> mapM_ annotatePC args-    GHC.RecCon fs -> do-      addDeltaAnnotation GHC.AnnOpenC-      annotatePC fs-      addDeltaAnnotation GHC.AnnCloseC-    GHC.InfixCon a1 a2 -> do-      annotatePC a1-      mapM_ annotatePC lns-      annotatePC a2---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP [GHC.LConDeclField name] where-  annotateP _ fs = do-       addDeltaAnnotation GHC.AnnOpenC -- '{'-       mapM_ annotatePC fs-       addDeltaAnnotation GHC.AnnDotdot-       addDeltaAnnotation GHC.AnnCloseC -- '}'---- -----------------------------------------------------------------------instance (GHC.DataId name) => AnnotateP (GHC.HsOverLit name) where-  annotateP l _ol = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP arg)-    => AnnotateP (GHC.HsWithBndrs name (GHC.Located arg)) where-  annotateP _ (GHC.HsWB thing _ _ _) = annotatePC thing---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,AnnotateP body) =>-                            AnnotateP (GHC.Stmt name (GHC.Located body)) where--  annotateP _ (GHC.LastStmt body _) = annotatePC body--  annotateP _ (GHC.BindStmt pat body _ _) = do-    annotatePC pat-    addDeltaAnnotation GHC.AnnLarrow-    annotatePC body-    addDeltaAnnotation GHC.AnnVbar -- possible in list comprehension--  annotateP _ (GHC.BodyStmt body _ _ _) = do-    annotatePC body--  annotateP _ (GHC.LetStmt lb) = do-    -- return () `debug` ("annotateP.LetStmt entered")-    addDeltaAnnotation GHC.AnnLet-    addDeltaAnnotation GHC.AnnOpenC -- '{'-    annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)-    addDeltaAnnotation GHC.AnnCloseC -- '}'-    -- return () `debug` ("annotateP.LetStmt done")--  annotateP _ (GHC.ParStmt pbs _ _) = do-    mapM_ annotateParStmtBlock pbs--  annotateP _ (GHC.TransStmt form stmts _b using by _ _ _) = do-    mapM_ annotatePC stmts-    case form of-      GHC.ThenForm -> do-        addDeltaAnnotation GHC.AnnThen-        annotatePC using-        addDeltaAnnotation GHC.AnnBy-        case by of-          Just b -> annotatePC b-          Nothing -> return ()-      GHC.GroupForm -> do-        addDeltaAnnotation GHC.AnnThen-        addDeltaAnnotation GHC.AnnGroup-        addDeltaAnnotation GHC.AnnBy-        case by of-          Just b -> annotatePC b-          Nothing -> return ()-        addDeltaAnnotation GHC.AnnUsing-        annotatePC using--  annotateP _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do-    addDeltaAnnotation GHC.AnnRec-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotationsInside GHC.AnnSemi-    mapM_ annotatePC stmts-    addDeltaAnnotation GHC.AnnCloseC---- -----------------------------------------------------------------------annotateParStmtBlock :: (GHC.DataId name,GHC.OutputableBndr name, AnnotateP name)-  =>  GHC.ParStmtBlock name name -> AP ()-annotateParStmtBlock (GHC.ParStmtBlock stmts _ns _) =-  mapM_ annotatePC stmts---- ------------------------------------------------------------------------- | Local binds need to be indented as a group, and thus need to have a--- SrcSpan around them so they can be processed via the normal--- annotatePC / exactPC machinery.-getLocalBindsSrcSpan :: GHC.HsLocalBinds name -> GHC.SrcSpan-getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsIn binds sigs))-  = case spans of-      []  -> GHC.noSrcSpan-      sss -> GHC.combineSrcSpans (head sss) (last sss)-  where-    spans = sort (map GHC.getLoc (GHC.bagToList binds) ++ map GHC.getLoc sigs)--getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsOut {}))-   = error "getLocalBindsSrcSpan: only valid after type checking"--getLocalBindsSrcSpan (GHC.HsIPBinds (GHC.IPBinds binds _))-  = case sort (map GHC.getLoc binds) of-      [] -> GHC.noSrcSpan-      sss -> GHC.combineSrcSpans (head sss) (last sss)--getLocalBindsSrcSpan (GHC.EmptyLocalBinds) = GHC.noSrcSpan---- ------------------------------------------------------------------------- | Generate a SrcSpan that enclosed the given list-getListSrcSpan :: [GHC.Located a] -> GHC.SrcSpan-getListSrcSpan ls-  = case ls of-      []  -> GHC.noSrcSpan-      sss -> GHC.combineLocs (head sss) (last sss)---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.HsLocalBinds name) where-  annotateP _ lb = annotateHsLocalBinds lb---- -----------------------------------------------------------------------annotateHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-                     => (GHC.HsLocalBinds name) -> AP ()-annotateHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do-    applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)-                       ++ prepareListAnnotation sigs-                         )-annotateHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {}))-   = error $ "annotateHsLocalBinds: only valid after type checking"--annotateHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ annotatePC binds-annotateHsLocalBinds (GHC.EmptyLocalBinds)                 = return ()---- -----------------------------------------------------------------------annotateMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,-                                               AnnotateP body)-                   => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body))-                   -> AP ()-annotateMatchGroup l (GHC.MG matches _ _ _)-  = annotateListWithLayout l matches---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,-                                               AnnotateP body)-  => AnnotateP [GHC.Located (GHC.Match name (GHC.Located body))] where-  annotateP _ ls = mapM_ annotatePC ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.HsExpr name) where-  annotateP l (GHC.HsVar n)           = annotateP l n-  annotateP l (GHC.HsIPVar _)         = addDeltaAnnotationExt l GHC.AnnVal-  annotateP l (GHC.HsOverLit _ov)     = addDeltaAnnotationExt l GHC.AnnVal-  annotateP l (GHC.HsLit _)           = addDeltaAnnotationExt l GHC.AnnVal--  annotateP l (GHC.HsLam match)       = do-    addDeltaAnnotation GHC.AnnLam-    annotateMatchGroup l match--  annotateP l (GHC.HsLamCase _ match) = annotateMatchGroup l match--  annotateP _ (GHC.HsApp e1 e2) = do-    annotatePC e1-    annotatePC e2--  annotateP _ (GHC.OpApp e1 e2 _ e3) = do-    annotatePC e1-    annotatePC e2-    annotatePC e3--  annotateP _ (GHC.NegApp e _) = do-    addDeltaAnnotation GHC.AnnMinus-    annotatePC e--  annotateP _ (GHC.HsPar e) = do-    addDeltaAnnotation GHC.AnnOpenP -- '('-    annotatePC e-    addDeltaAnnotation GHC.AnnCloseP -- ')'--  annotateP _ (GHC.SectionL e1 e2) = do-    annotatePC e1-    annotatePC e2--  annotateP _ (GHC.SectionR e1 e2) = do-    annotatePC e1-    annotatePC e2--  annotateP _ (GHC.ExplicitTuple args _boxity) = do-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenP-    mapM_ annotatePC args-    addDeltaAnnotation GHC.AnnCloseP-    addDeltaAnnotation GHC.AnnClose--  annotateP l (GHC.HsCase e1 matches) = do-    addDeltaAnnotation GHC.AnnCase-    annotatePC e1-    addDeltaAnnotation GHC.AnnOf-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotationsInside GHC.AnnSemi-    annotateMatchGroup l matches-    addDeltaAnnotation GHC.AnnCloseC--  annotateP _ (GHC.HsIf _ e1 e2 e3) = do-    addDeltaAnnotation GHC.AnnIf-    annotatePC e1-    addDeltaAnnotationLs GHC.AnnSemi 0-    addDeltaAnnotation GHC.AnnThen-    annotatePC e2-    addDeltaAnnotationLs GHC.AnnSemi 1-    addDeltaAnnotation GHC.AnnElse-    annotatePC e3--  annotateP _ (GHC.HsMultiIf _ rhs) = do-    addDeltaAnnotation GHC.AnnIf-    mapM_ annotatePC rhs--  annotateP _ (GHC.HsLet binds e) = do-    setLayoutOn True -- Make sure the 'in' gets indented too-    addDeltaAnnotation GHC.AnnLet-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotationsInside GHC.AnnSemi-    annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)-    addDeltaAnnotation GHC.AnnCloseC-    addDeltaAnnotation GHC.AnnIn-    annotatePC e--  annotateP l (GHC.HsDo cts es _) = do-    addDeltaAnnotation GHC.AnnDo-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenS-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotationsInside GHC.AnnSemi-    if isListComp cts-      then do-        annotatePC (last es)-        addDeltaAnnotation GHC.AnnVbar-        mapM_ annotatePC (init es)-      else do-        annotateListWithLayout l es-    addDeltaAnnotation GHC.AnnCloseS-    addDeltaAnnotation GHC.AnnCloseC-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.ExplicitList _ _ es) = do-    addDeltaAnnotation GHC.AnnOpenS-    mapM_ annotatePC es-    addDeltaAnnotation GHC.AnnCloseS--  annotateP _ (GHC.ExplicitPArr _ es)   = do-    addDeltaAnnotation GHC.AnnOpen-    mapM_ annotatePC es-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do-    annotatePC n-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotation GHC.AnnDotdot-    mapM_ annotatePC fs-    addDeltaAnnotation GHC.AnnCloseC--  annotateP _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do-    annotatePC e-    addDeltaAnnotation GHC.AnnOpenC-    addDeltaAnnotation GHC.AnnDotdot-    mapM_ annotatePC fs-    addDeltaAnnotation GHC.AnnCloseC--  annotateP _ (GHC.ExprWithTySig e typ _) = do-    annotatePC e-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ--  annotateP _ (GHC.ExprWithTySigOut e typ) = do-    annotatePC e-    addDeltaAnnotation GHC.AnnDcolon-    annotatePC typ--  annotateP _ (GHC.ArithSeq _ _ seqInfo) = do-    addDeltaAnnotation GHC.AnnOpenS -- '['-    case seqInfo of-        GHC.From e -> do-          annotatePC e-          addDeltaAnnotation GHC.AnnDotdot-        GHC.FromTo e1 e2 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnDotdot-          annotatePC e2-        GHC.FromThen e1 e2 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnComma-          annotatePC e2-          addDeltaAnnotation GHC.AnnDotdot-        GHC.FromThenTo e1 e2 e3 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnComma-          annotatePC e2-          addDeltaAnnotation GHC.AnnDotdot-          annotatePC e3-    addDeltaAnnotation GHC.AnnCloseS -- ']'--  annotateP _ (GHC.PArrSeq _ seqInfo) = do-    addDeltaAnnotation GHC.AnnOpen -- '[:'-    case seqInfo of-        GHC.From e -> do-          annotatePC e-          addDeltaAnnotation GHC.AnnDotdot-        GHC.FromTo e1 e2 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnDotdot-          annotatePC e2-        GHC.FromThen e1 e2 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnComma-          annotatePC e2-          addDeltaAnnotation GHC.AnnDotdot-        GHC.FromThenTo e1 e2 e3 -> do-          annotatePC e1-          addDeltaAnnotation GHC.AnnComma-          annotatePC e2-          addDeltaAnnotation GHC.AnnDotdot-          annotatePC e3-    addDeltaAnnotation GHC.AnnClose -- ':]'--  annotateP _ (GHC.HsSCC _ _csFStr e) = do-    addDeltaAnnotation GHC.AnnOpen -- '{-# SCC'-    addDeltaAnnotation GHC.AnnVal-    addDeltaAnnotation GHC.AnnValStr-    addDeltaAnnotation GHC.AnnClose -- '#-}'-    annotatePC e--  annotateP _ (GHC.HsCoreAnn _ _csFStr e) = do-    addDeltaAnnotation GHC.AnnOpen -- '{-# CORE'-    addDeltaAnnotation GHC.AnnVal-    addDeltaAnnotation GHC.AnnClose -- '#-}'-    annotatePC e--  annotateP l (GHC.HsBracket (GHC.VarBr _ _)) = do-    addDeltaAnnotationExt l GHC.AnnVal-  annotateP _ (GHC.HsBracket (GHC.DecBrL ds)) = do-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnOpenC-    mapM_ annotatePC ds-    addDeltaAnnotation GHC.AnnCloseC-    addDeltaAnnotation GHC.AnnClose-  annotateP _ (GHC.HsBracket (GHC.ExpBr e)) = do-    addDeltaAnnotation GHC.AnnOpen-    annotatePC e-    addDeltaAnnotation GHC.AnnClose-  annotateP _ (GHC.HsBracket (GHC.TExpBr e)) = do-    addDeltaAnnotation GHC.AnnOpen-    annotatePC e-    addDeltaAnnotation GHC.AnnClose-  annotateP _ (GHC.HsBracket (GHC.TypBr e)) = do-    addDeltaAnnotation GHC.AnnOpen-    annotatePC e-    addDeltaAnnotation GHC.AnnClose-  annotateP _ (GHC.HsBracket (GHC.PatBr e)) = do-    addDeltaAnnotation GHC.AnnOpen-    annotatePC e-    addDeltaAnnotation GHC.AnnClose--  annotateP _ (GHC.HsRnBracketOut _ _) = return ()-  annotateP _ (GHC.HsTcBracketOut _ _) = return ()--  annotateP _ (GHC.HsSpliceE _typed (GHC.HsSplice _ e)) = do-    addDeltaAnnotation GHC.AnnOpen -- possible '$('-    annotatePC e-    addDeltaAnnotation GHC.AnnClose -- possible ')'--  annotateP l (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote _ _ _)) = do-    addDeltaAnnotationExt l GHC.AnnVal--  annotateP _ (GHC.HsProc p c) = do-    addDeltaAnnotation GHC.AnnProc-    annotatePC p-    addDeltaAnnotation GHC.AnnRarrow-    annotatePC c--  annotateP _ (GHC.HsStatic e) = do-    addDeltaAnnotation GHC.AnnStatic-    annotatePC e--  annotateP _ (GHC.HsArrApp e1 e2 _ _ _) = do-    annotatePC e1-    -- only one of the next 4 will be resent-    addDeltaAnnotation GHC.Annlarrowtail-    addDeltaAnnotation GHC.Annrarrowtail-    addDeltaAnnotation GHC.AnnLarrowtail-    addDeltaAnnotation GHC.AnnRarrowtail--    annotatePC e2--  annotateP _ (GHC.HsArrForm e _ cs) = do-    addDeltaAnnotation GHC.AnnOpen -- '(|'-    annotatePC e-    mapM_ annotatePC cs-    addDeltaAnnotation GHC.AnnClose -- '|)'--  annotateP _ (GHC.HsTick _ _) = return ()-  annotateP _ (GHC.HsBinTick _ _ _) = return ()--  annotateP _ (GHC.HsTickPragma _ (_str,(_v1,_v2),(_v3,_v4)) e) = do-    -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'-    addDeltaAnnotation   GHC.AnnOpen     -- '{-# GENERATED'-    addDeltaAnnotationLs GHC.AnnVal   0 -- STRING-    addDeltaAnnotationLs GHC.AnnVal   1 -- INTEGER-    addDeltaAnnotationLs GHC.AnnColon 0 -- ':'-    addDeltaAnnotationLs GHC.AnnVal   2 -- INTEGER-    addDeltaAnnotation   GHC.AnnMinus   -- '-'-    addDeltaAnnotationLs GHC.AnnVal   3 -- INTEGER-    addDeltaAnnotationLs GHC.AnnColon 1 -- ':'-    addDeltaAnnotationLs GHC.AnnVal   4 -- INTEGER-    addDeltaAnnotation   GHC.AnnClose   -- '#-}'-    annotatePC e--  annotateP l (GHC.EWildPat) = do-    addDeltaAnnotationExt l GHC.AnnVal--  annotateP _ (GHC.EAsPat ln e) = do-    annotatePC ln-    addDeltaAnnotation GHC.AnnAt-    annotatePC e--  annotateP _ (GHC.EViewPat e1 e2) = do-    annotatePC e1-    addDeltaAnnotation GHC.AnnRarrow-    annotatePC e2--  annotateP _ (GHC.ELazyPat e) = do-    addDeltaAnnotation GHC.AnnTilde-    annotatePC e--  annotateP _ (GHC.HsType ty) = annotatePC ty--  annotateP _ (GHC.HsWrap _ _) = return ()-  annotateP _ (GHC.HsUnboundVar _) = return ()----- ------------------------------------------------------------------------- |Used for declarations that need to be aligned together, e.g. in a--- do or let .. in statement/expr-instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP ([GHC.ExprLStmt name]) where-  annotateP _ ls = mapM_ annotatePC ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.HsTupArg name) where-  annotateP _ (GHC.Present e) = do-    annotatePC e--  annotateP _ (GHC.Missing _) = do-    addDeltaAnnotation GHC.AnnComma---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP (GHC.HsCmdTop name) where-  annotateP _ (GHC.HsCmdTop cmd _ _ _) = annotatePC cmd--instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-   => AnnotateP (GHC.HsCmd name) where-  annotateP _ (GHC.HsCmdArrApp e1 e2 _ _ _) = do-    annotatePC e1-    -- only one of the next 4 will be resent-    addDeltaAnnotation GHC.Annlarrowtail-    addDeltaAnnotation GHC.Annrarrowtail-    addDeltaAnnotation GHC.AnnLarrowtail-    addDeltaAnnotation GHC.AnnRarrowtail--    annotatePC e2--  annotateP _ (GHC.HsCmdArrForm e _mf cs) = do-    addDeltaAnnotation GHC.AnnOpen -- '(|'-    annotatePC e-    mapM_ annotatePC cs-    addDeltaAnnotation GHC.AnnClose -- '|)'--  annotateP _ (GHC.HsCmdApp e1 e2) = do-    annotatePC e1-    annotatePC e2--  annotateP l (GHC.HsCmdLam match) = do-    addDeltaAnnotation GHC.AnnLam-    annotateMatchGroup l match--  annotateP _ (GHC.HsCmdPar e) = do-    addDeltaAnnotation GHC.AnnOpenP -- '('-    annotatePC e-    addDeltaAnnotation GHC.AnnCloseP -- ')'--  annotateP l (GHC.HsCmdCase e1 matches) = do-    addDeltaAnnotation GHC.AnnCase-    annotatePC e1-    addDeltaAnnotation GHC.AnnOf-    addDeltaAnnotation GHC.AnnOpenC-    annotateMatchGroup l matches-    addDeltaAnnotation GHC.AnnCloseC--  annotateP _ (GHC.HsCmdIf _ e1 e2 e3) = do-    addDeltaAnnotation GHC.AnnIf-    annotatePC e1-    addDeltaAnnotationLs GHC.AnnSemi 0-    addDeltaAnnotation GHC.AnnThen-    annotatePC e2-    addDeltaAnnotationLs GHC.AnnSemi 1-    addDeltaAnnotation GHC.AnnElse-    annotatePC e3--  annotateP _ (GHC.HsCmdLet binds e) = do-    addDeltaAnnotation GHC.AnnLet-    addDeltaAnnotation GHC.AnnOpenC-    annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)-    addDeltaAnnotation GHC.AnnCloseC-    addDeltaAnnotation GHC.AnnIn-    annotatePC e--  annotateP l (GHC.HsCmdDo es _) = do-    addDeltaAnnotation GHC.AnnDo-    addDeltaAnnotation GHC.AnnOpenC-    -- mapM_ annotatePC es-    annotateListWithLayout l es-    addDeltaAnnotation GHC.AnnCloseC--  annotateP _ (GHC.HsCmdCast {}) = error $ "annotateP.HsCmdCast: only valid after type checker"----- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => AnnotateP [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where-  annotateP _ ls = mapM_ annotatePC ls---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-     => AnnotateP (GHC.TyClDecl name) where--  annotateP l (GHC.FamDecl famdecl) = annotateP l famdecl--  annotateP _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do-    addDeltaAnnotation GHC.AnnType-    annotatePC ln-    mapM_ annotatePC tyvars-    addDeltaAnnotation GHC.AnnEqual-    annotatePC typ--  annotateP _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)-                (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do-    addDeltaAnnotation GHC.AnnData-    addDeltaAnnotation GHC.AnnNewtype-    annotateMaybe mctyp-    annotatePC ctx-    addDeltaAnnotation GHC.AnnDarrow-    annotateTyClass ln tyVars-    addDeltaAnnotation GHC.AnnDcolon-    annotateMaybe mk-    addDeltaAnnotation GHC.AnnEqual-    addDeltaAnnotation GHC.AnnWhere-    mapM_ annotatePC cons-    annotateMaybe mderivs--  -- -------------------------------------  annotateP _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds-                          sigs meths ats atdefs docs _) = do-    addDeltaAnnotation GHC.AnnClass-    annotatePC ctx--    annotateTyClass ln tyVars--    addDeltaAnnotation GHC.AnnVbar-    mapM_ annotatePC fds-    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC -- '{'-    addDeltaAnnotationsInside GHC.AnnSemi-    applyListAnnotations (prepareListAnnotation sigs-                       ++ prepareListAnnotation (GHC.bagToList meths)-                       ++ prepareListAnnotation ats-                       ++ prepareListAnnotation atdefs-                       ++ prepareListAnnotation docs-                         )-    addDeltaAnnotation GHC.AnnCloseC -- '}'---- -----------------------------------------------------------------------annotateTyClass :: (AnnotateP a, AnnotateP ast)-                => GHC.Located a -> [GHC.Located ast] -> AP ()-annotateTyClass ln tyVars = do-    addDeltaAnnotations GHC.AnnOpenP-    applyListAnnotations (prepareListAnnotation [ln]-                      ++ prepareListAnnotation (take 2 tyVars))-    addDeltaAnnotations GHC.AnnCloseP-    mapM_ annotatePC (drop 2 tyVars)---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name, GHC.OutputableBndr name)-   => AnnotateP (GHC.FamilyDecl name) where-  annotateP _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do-    addDeltaAnnotation GHC.AnnType-    addDeltaAnnotation GHC.AnnData-    addDeltaAnnotation GHC.AnnFamily-    annotatePC ln-    mapM_ annotatePC tyvars-    addDeltaAnnotation GHC.AnnDcolon-    annotateMaybe mkind-    addDeltaAnnotation GHC.AnnWhere-    addDeltaAnnotation GHC.AnnOpenC -- {-    case info of-      GHC.ClosedTypeFamily eqns -> mapM_ annotatePC eqns-      _ -> return ()-    case info of-      GHC.ClosedTypeFamily eqns -> mapM_ annotatePC eqns-      _ -> return ()-    addDeltaAnnotation GHC.AnnCloseC -- }---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name)-   => AnnotateP (GHC.TyFamInstEqn name) where-  annotateP _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do-    annotatePC ln-    mapM_ annotatePC pats-    addDeltaAnnotation GHC.AnnEqual-    annotatePC typ----- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name)-  => AnnotateP (GHC.TyFamDefltEqn name) where-  annotateP _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do-    annotatePC ln-    mapM_ annotatePC bndrs-    addDeltaAnnotation GHC.AnnEqual-    annotatePC typ---- ------------------------------------------------------------------------- TODO: modify lexer etc, in the meantime to not set haddock flag-instance AnnotateP GHC.DocDecl where-  annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal---- -----------------------------------------------------------------------annotateDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-  => GHC.SrcSpan -> GHC.HsDataDefn name -> AP ()-annotateDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do-  annotatePC ctx-  annotateMaybe typ-  annotateMaybe mk-  mapM_ annotatePC cons-  case mderivs of-    Nothing -> return ()-    Just d -> annotatePC d---- ------------------------------------------------------------------------- Note: GHC.HsContext name aliases to here too-instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name)-     => AnnotateP [GHC.LHsType name] where-  annotateP l ts = do-    return () `debug` ("annotateP.HsContext:l=" ++ showGhc l)-    addDeltaAnnotation GHC.AnnDeriving-    addDeltaAnnotation GHC.AnnOpenP-    mapM_ annotatePC ts-    addDeltaAnnotation GHC.AnnCloseP-    addDeltaAnnotation GHC.AnnDarrow---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name)-      => AnnotateP (GHC.ConDecl name) where-  annotateP _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx-                         dets res _ _) = do-    case res of-      GHC.ResTyH98 -> do-        addDeltaAnnotation GHC.AnnForall-        mapM_ annotatePC bndrs-        addDeltaAnnotation GHC.AnnDot--        annotatePC ctx-        addDeltaAnnotation GHC.AnnDarrow--        case dets of-          GHC.InfixCon _ _ -> return ()-          _ -> mapM_ annotatePC lns--        annotateHsConDeclDetails lns dets--      GHC.ResTyGADT ls ty -> do-        -- only print names if not infix-        case dets of-          GHC.InfixCon _ _ -> return ()-          _ -> mapM_ annotatePC lns--        annotateHsConDeclDetails lns dets--        addDeltaAnnotation GHC.AnnDcolon--        annotatePC (GHC.L ls (ResTyGADTHook bndrs))--        annotatePC ctx-        addDeltaAnnotation GHC.AnnDarrow--        annotatePC ty---    addDeltaAnnotation GHC.AnnVbar---- -----------------------------------------------------------------------instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) =>-              AnnotateP (ResTyGADTHook name) where-  annotateP _ (ResTyGADTHook bndrs) = do-    addDeltaAnnotation GHC.AnnForall-    mapM_ annotatePC bndrs-    addDeltaAnnotation GHC.AnnDot---- -----------------------------------------------------------------------instance (AnnotateP name,AnnotateP a)-  => AnnotateP (GHC.HsRecField name (GHC.Located a)) where-  annotateP _ (GHC.HsRecField n e _) = do-    annotatePC n-    addDeltaAnnotation GHC.AnnEqual-    annotatePC e---- -----------------------------------------------------------------------instance (GHC.DataId name,AnnotateP name)-    => AnnotateP (GHC.FunDep (GHC.Located name)) where--  annotateP _ (ls,rs) = do-    mapM_ annotatePC ls-    addDeltaAnnotation GHC.AnnRarrow-    mapM_ annotatePC rs---- -----------------------------------------------------------------------instance AnnotateP (GHC.CType) where-  annotateP _ _ = do-    addDeltaAnnotation GHC.AnnOpen-    addDeltaAnnotation GHC.AnnHeader-    addDeltaAnnotation GHC.AnnVal-    addDeltaAnnotation GHC.AnnClose---- ------------------------------------------------------------------------- | Apply the delta to the current position, taking into account the--- current column offset-undeltaComment :: Pos -> Int -> DComment -> Comment-undeltaComment l con (DComment (dps,dpe) s) = r-    -- `debug` ("undeltaComment:(l,con,dcomment,r)=" ++ show (l,con,dco,r))-  where-    r = Comment ((adj dps $ undelta l dps co),(adj dps $ undelta l dpe co)) s-    co = con-    dc = - con -- + (coo - con)--    -- adj makes provision for the possible movement of the-    -- surrounding context, and so applies the difference between the-    -- original and current offsets-    adj (DP (   0,_dco)) (row,c) = (row,c)-    adj (DP (_dro,_dco)) (row,c) = (row,c + dc)---- | Create a delta covering the gap between the end of the first--- @SrcSpan@ and the start of the second.-deltaFromSrcSpans :: GHC.SrcSpan -> GHC.SrcSpan -> DeltaPos-deltaFromSrcSpans ss1 ss2 = ss2delta (ss2posEnd ss1) ss2--ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos-ss2delta ref ss = ss2deltaP ref (ss2pos ss)---- | Convert the start of the second @Pos@ to be an offset from the--- first. The assumption is the reference starts before the second @Pos@-ss2deltaP :: Pos -> Pos -> DeltaPos-ss2deltaP (refl,refc) (l,c) = DP (lo,co)-  where-    lo = l - refl-    co = if lo == 0 then c - refc-                    else c---- | Apply the delta to the current position, taking into account the--- current column offset if advancing to a new line-undelta :: Pos -> DeltaPos -> ColOffset -> Pos-undelta (l,c) (DP (dl,dc)) co = (fl,fc)-  where-    fl = l + dl-    fc = if dl == 0 then c  + dc-                    else co + dc---- -----------------------------------------------------------------------ss2pos :: GHC.SrcSpan -> Pos-ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss)--ss2posEnd :: GHC.SrcSpan -> Pos-ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)--ss2span :: GHC.SrcSpan -> Span-ss2span ss = (ss2pos ss,ss2posEnd ss)--srcSpanStart :: GHC.SrcSpan -> Pos-srcSpanStart ss = (srcSpanStartLine ss,srcSpanStartColumn ss)--srcSpanEnd :: GHC.SrcSpan -> Pos-srcSpanEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)---srcSpanEndColumn :: GHC.SrcSpan -> Int-srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s-srcSpanEndColumn _ = 0--srcSpanStartColumn :: GHC.SrcSpan -> Int-srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s-srcSpanStartColumn _ = 0--srcSpanEndLine :: GHC.SrcSpan -> Int-srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s-srcSpanEndLine _ = 0--srcSpanStartLine :: GHC.SrcSpan -> Int-srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s-srcSpanStartLine _ = 0---- -----------------------------------------------------------------------span2ss :: Span -> GHC.SrcSpan-span2ss ((sr,sc),(er,ec)) = l-  where-   filename = (GHC.mkFastString "f")-   l = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec)---- -----------------------------------------------------------------------isPointSrcSpan :: GHC.SrcSpan -> Bool-isPointSrcSpan ss = s == e where (s,e) = ss2span ss---- -----------------------------------------------------------------------isListComp :: GHC.HsStmtContext name -> Bool-isListComp cts = case cts of-          GHC.ListComp  -> True-          GHC.MonadComp -> True-          GHC.PArrComp  -> True--          GHC.DoExpr       -> False-          GHC.MDoExpr      -> False-          GHC.ArrowExpr    -> False-          GHC.GhciStmtCtxt -> False--          GHC.PatGuard {}      -> False-          GHC.ParStmtCtxt {}   -> False-          GHC.TransStmtCtxt {} -> False---- -----------------------------------------------------------------------ghcCommentText :: GHC.Located GHC.AnnotationComment -> String-ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s))  = s-ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s))  = s-ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s-ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s))    = s-ghcCommentText (GHC.L _ (GHC.AnnDocOptions s))      = s-ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s))   = s-ghcCommentText (GHC.L _ (GHC.AnnLineComment s))     = s-ghcCommentText (GHC.L _ (GHC.AnnBlockComment s))    = "{-" ++ s ++ "-}"---- -----------------------------------------------------------------------isSymbolRdrName :: GHC.RdrName -> Bool-isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n--rdrName2String :: GHC.RdrName -> String-rdrName2String r =-  case GHC.isExact_maybe r of-    Just n  -> name2String n-    Nothing ->-      case r of-        GHC.Unqual _occ -> GHC.occNameString $ GHC.rdrNameOcc r-        GHC.Qual modname _occ -> GHC.moduleNameString modname ++ "."-                            ++ (GHC.occNameString $ GHC.rdrNameOcc r)--name2String :: GHC.Name -> String-name2String name = showGhc name---- |Show a GHC API structure-showGhc :: (GHC.Outputable a) => a -> String-showGhc x = GHC.showPpr GHC.unsafeGlobalDynFlags x----- |Show a GHC API structure-showGhcDebug :: (GHC.Outputable a) => a -> String-showGhcDebug x = GHC.showSDocDebug GHC.unsafeGlobalDynFlags (GHC.ppr x)---- -----------------------------------------------------------------------instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where-  show (GHC.L l tok) = show ((srcSpanStart l, srcSpanEnd l),tok)---- -----------------------------------------------------------------------pp :: GHC.Outputable a => a -> String-pp a = GHC.showPpr GHC.unsafeGlobalDynFlags a---- ------------------------------------------------------------------------- Based on ghc-syb-utils version, but adding the annotation--- information to each SrcLoc.-showAnnData :: Data a => Anns -> Int -> a -> String-showAnnData anns n =-  generic -- `ext1Q` located-          `ext1Q` list-          `extQ` string `extQ` fastString `extQ` srcSpan-          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon-          `extQ` overLit-          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-          `extQ` fixity-          `ext2Q` located-  where generic :: Data a => a -> String-        generic t = indent n ++ "(" ++ showConstr (toConstr t)-                 ++ space (concat (intersperse " " (gmapQ (showAnnData anns (n+1)) t))) ++ ")"-        space "" = ""-        space s  = ' ':s-        indent i = "\n" ++ replicate i ' '-        string     = show :: String -> String-        fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String-        list l     = indent n ++ "["-                              ++ concat (intersperse "," (map (showAnnData anns (n+1)) l)) ++ "]"--        name       = ("{Name: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Name -> String-        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString-        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String--        -- srcSpan    = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String-        srcSpan :: GHC.SrcSpan -> String-        srcSpan ss = "{ "++ (showSDoc_ (GHC.hang (GHC.ppr ss) (n+2)-                                                 -- (GHC.ppr (Map.lookup ss anns)-                                                 (GHC.text "")-                                                 ))-                      ++"}"--        var        = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String-        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String--        overLit :: (GHC.HsOverLit GHC.RdrName) -> String-        overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr--        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String-        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList-        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String-        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList-        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String-        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList--        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems--        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String--        located :: (Data b,Data loc) => GHC.GenLocated loc b -> String-        -- located la = show (getAnnotationEP la anns)-        located la@(GHC.L ss a) = indent n ++ "("-                                      ++ case (cast ss) of-                                           Just (s::GHC.SrcSpan) -> srcSpan s-                                                                    ++ indent (n + 1) ++ show (getAnnotationEP (GHC.L s a) anns)-                                           Nothing -> "nnnnnnnn"-                                      ++ showAnnData anns (n+1) a-                                      ++ ")"---- -----------------------------------------------------------------------showSDoc_ :: GHC.SDoc -> String-showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags---- ------------------------------------------------------------------------ Putting these here for the time being, to avoid import loops--ghead :: String -> [a] -> a-ghead  info []    = error $ "ghead "++info++" []"-ghead _info (h:_) = h--glast :: String -> [a] -> a-glast  info []    = error $ "glast " ++ info ++ " []"-glast _info h     = last h--gtail :: String -> [a] -> [a]-gtail  info []   = error $ "gtail " ++ info ++ " []"-gtail _info h    = tail h--gfromJust :: [Char] -> Maybe a -> a-gfromJust _info (Just h) = h-gfromJust  info Nothing = error $ "gfromJust " ++ info ++ " Nothing"-+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.GHC.ExactPrint.Utils+  (++  srcSpanStartLine+  , srcSpanEndLine+  , srcSpanStartColumn+  , srcSpanEndColumn++  , ss2span+  , ss2pos+  , ss2posEnd+  , span2ss+  , undelta+  , rdrName2String+  , isSymbolRdrName+  , deltaFromSrcSpans+  , ghcCommentText+  , isPointSrcSpan+  , ss2deltaP+  , isGoodDelta++  , isListComp++  , showGhc+  , showAnnData+++  -- * For tests+  , debug+  , debugM+  , warn++  ) where+++import Control.Monad (when)+import Data.Data (Data, toConstr, showConstr, cast)+import Data.Generics (extQ, ext1Q, ext2Q, gmapQ)+import Data.List (intercalate)++import Language.Haskell.GHC.ExactPrint.Types++import qualified GHC+import qualified Bag            as GHC+import qualified DynFlags       as GHC+import qualified FastString     as GHC+import qualified Name           as GHC+import qualified NameSet        as GHC+import qualified Outputable     as GHC+import qualified RdrName        as GHC+import qualified Var            as GHC++import qualified OccName(occNameString)++import Debug.Trace++-- ---------------------------------------------------------------------++-- |Global switch to enable debug tracing in ghc-exactprint+debugEnabledFlag :: Bool+-- debugEnabledFlag = True+debugEnabledFlag = False++-- |Provide a version of trace the comes at the end of the line, so it can+-- easily be commented out when debugging different things.+debug :: c -> String -> c+debug c s = if debugEnabledFlag+              then trace s c+              else c++debugM :: Monad m => String -> m ()+debugM s = when debugEnabledFlag $ traceM s++-- ---------------------------------------------------------------------++warn :: c -> String -> c+-- warn = flip trace+warn c _ = c++isGoodDelta :: DeltaPos -> Bool+isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0++-- | Create a delta covering the gap between the end of the first+-- @SrcSpan@ and the start of the second.+deltaFromSrcSpans :: GHC.SrcSpan -> GHC.SrcSpan -> DeltaPos+deltaFromSrcSpans ss1 ss2 = ss2delta (ss2posEnd ss1) ss2++ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos+ss2delta ref ss = ss2deltaP ref (ss2pos ss)++-- | Convert the start of the second @Pos@ to be an offset from the+-- first. The assumption is the reference starts before the second @Pos@+ss2deltaP :: Pos -> Pos -> DeltaPos+ss2deltaP (refl,refc) (l,c) = DP (lo,co)+  where+    lo = l - refl+    co = if lo == 0 then c - refc+                    else c++-- | Apply the delta to the current position, taking into account the+-- current column offset if advancing to a new line+undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos+undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc)+  where+    fl = l + dl+    fc = if dl == 0 then c  + dc+                    else co + dc++-- ---------------------------------------------------------------------++ss2pos :: GHC.SrcSpan -> Pos+ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss)++ss2posEnd :: GHC.SrcSpan -> Pos+ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)++ss2span :: GHC.SrcSpan -> Span+ss2span ss = (ss2pos ss,ss2posEnd ss)++srcSpanEndColumn :: GHC.SrcSpan -> Int+srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s+srcSpanEndColumn _ = 0++srcSpanStartColumn :: GHC.SrcSpan -> Int+srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s+srcSpanStartColumn _ = 0++srcSpanEndLine :: GHC.SrcSpan -> Int+srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s+srcSpanEndLine _ = 0++srcSpanStartLine :: GHC.SrcSpan -> Int+srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s+srcSpanStartLine _ = 0++-- ---------------------------------------------------------------------++span2ss :: Span -> GHC.SrcSpan+span2ss ((sr,sc),(er,ec)) = l+  where+   filename = GHC.mkFastString "f"+   l = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec)++-- ---------------------------------------------------------------------++isPointSrcSpan :: GHC.SrcSpan -> Bool+isPointSrcSpan ss = s == e where (s,e) = ss2span ss++-- ---------------------------------------------------------------------++isListComp :: GHC.HsStmtContext name -> Bool+isListComp cts = case cts of+          GHC.ListComp  -> True+          GHC.MonadComp -> True+          GHC.PArrComp  -> True++          GHC.DoExpr       -> False+          GHC.MDoExpr      -> False+          GHC.ArrowExpr    -> False+          GHC.GhciStmtCtxt -> False++          GHC.PatGuard {}      -> False+          GHC.ParStmtCtxt {}   -> False+          GHC.TransStmtCtxt {} -> False++-- ---------------------------------------------------------------------++ghcCommentText :: GHC.Located GHC.AnnotationComment -> String+ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s))  = s+ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s))  = s+ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s+ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s))    = s+ghcCommentText (GHC.L _ (GHC.AnnDocOptions s))      = s+ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s))   = s+ghcCommentText (GHC.L _ (GHC.AnnLineComment s))     = s+ghcCommentText (GHC.L _ (GHC.AnnBlockComment s))    = "{-" ++ s ++ "-}"++-- ---------------------------------------------------------------------++isSymbolRdrName :: GHC.RdrName -> Bool+isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n++rdrName2String :: GHC.RdrName -> String+rdrName2String r =+  case GHC.isExact_maybe r of+    Just n  -> name2String n+    Nothing ->+      case r of+        GHC.Unqual _occ       -> GHC.occNameString $ GHC.rdrNameOcc r+        GHC.Qual modname _occ -> GHC.moduleNameString modname ++ "."+                            ++ GHC.occNameString (GHC.rdrNameOcc r)+        GHC.Orig _ _          -> error "GHC.Orig introduced after renaming"+        GHC.Exact _           -> error "GHC.Exact introduced after renaming"++name2String :: GHC.Name -> String+name2String = showGhc++-- |Show a GHC API structure+showGhc :: (GHC.Outputable a) => a -> String+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags++-- ---------------------------------------------------------------------++-- Based on ghc-syb-utils version, but adding the annotation+-- information to each SrcLoc.+showAnnData :: Data a => Anns -> Int -> a -> String+showAnnData anns n =+  generic -- `ext1Q` located+          `ext1Q` list+          `extQ` string `extQ` fastString `extQ` srcSpan+          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon+          `extQ` overLit+          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+          `extQ` fixity+          `ext2Q` located+  where generic :: Data a => a -> String+        generic t = indent n ++ "(" ++ showConstr (toConstr t)+                 ++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")"+        space "" = ""+        space s  = ' ':s+        indent i = "\n" ++ replicate i ' '+        string     = show :: String -> String+        fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String+        list l     = indent n ++ "["+                              ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]"++        name       = ("{Name: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Name -> String+        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString+        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String++        -- srcSpan    = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String+        srcSpan :: GHC.SrcSpan -> String+        srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2)+                                                 -- (GHC.ppr (Map.lookup ss anns)+                                                 (GHC.text "")+                                                 )+                      ++"}"++        var        = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String+        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String++        overLit :: GHC.HsOverLit GHC.RdrName -> String+        overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr++        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String+        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList+        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String+        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList+        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String+        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList++        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems++        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String++        located :: (Data b,Data loc) => GHC.GenLocated loc b -> String+        -- located la = show (getAnnotationEP la anns)+        located (GHC.L ss a) =+          indent n ++ "("+            ++ case cast ss of+                    Just (s :: GHC.SrcSpan) ->+                      srcSpan s+                      ++ indent (n + 1) +++                      show (getAnnotationEP (GHC.L s a) anns)+                    Nothing -> "nnnnnnnn"+                  ++ showAnnData anns (n+1) a+                  ++ ")"++-- ---------------------------------------------------------------------++showSDoc_ :: GHC.SDoc -> String+showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags++-- ---------------------------------------------------------------------
tests/Test.hs view
@@ -1,27 +1,24 @@+{-# LANGUAGE TupleSections #-} -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests. module Main where  import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Types + import GHC.Paths ( libdir )  -import qualified Bag                   as GHC import qualified DynFlags      as GHC-import qualified ErrUtils              as GHC import qualified FastString    as GHC import qualified GHC           as GHC import qualified HscTypes              as GHC-import qualified Lexer                 as GHC import qualified MonadUtils    as GHC import qualified OccName       as GHC import qualified Outputable            as GHC import qualified RdrName       as GHC-import qualified SrcLoc                as GHC import qualified StringBuffer          as GHC--- import qualified Outputable    as GHC  import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB@@ -37,10 +34,15 @@  import Test.HUnit --- import qualified Data.Map as Map+import Control.Applicative+import Data.List (partition)  -- --------------------------------------------------------------------- +ghead :: String -> [a] -> a+ghead s [] = error ("Empty list at: " ++ s)+ghead s (x:xs) = x+ main :: IO () main = do   cnts <- runTestTT tests@@ -130,7 +132,13 @@   , mkTestMod "B.hs"                     "Main"   , mkTestMod "LayoutWhere.hs"           "Main"   , mkTestMod "LayoutLet.hs"             "Main"+  , mkTestMod "LayoutLet2.hs"            "LayoutLet2"+  , mkTestMod "LayoutLet3.hs"            "LayoutLet3"+  , mkTestMod "LayoutLet4.hs"            "LayoutLet4"   , mkTestMod "LayoutIn1.hs"             "LayoutIn1"+  , mkTestMod "LayoutIn3.hs"             "LayoutIn3"+  , mkTestMod "LayoutIn3a.hs"            "LayoutIn3a"+  , mkTestMod "LayoutIn3b.hs"            "LayoutIn3b"   , mkTestMod "LayoutIn4.hs"             "LayoutIn4"   , mkTestMod "Deprecation.hs"           "Deprecation"   , mkTestMod "Infix.hs"                 "Main"@@ -139,12 +147,18 @@   , mkTestMod "LetExprSemi.hs"           "LetExprSemi"   , mkTestMod "WhereIn4.hs"              "WhereIn4"   , mkTestMod "LocToName.hs"             "LocToName"+  , mkTestMod "IfThenElse1.hs"           "Main"+  , mkTestMod "IfThenElse2.hs"           "Main"+  , mkTestMod "IfThenElse3.hs"           "Main"    , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2"   , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"   , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"   , mkTestModChange changeRename1    "Rename1.hs"    "Main"   , mkTestModChange changeLayoutIn1  "LayoutIn1.hs"  "LayoutIn1"+  , mkTestModChange changeLayoutIn3  "LayoutIn3.hs"  "LayoutIn3"+  , mkTestModChange changeLayoutIn3  "LayoutIn3a.hs" "LayoutIn3a"+  , mkTestModChange changeLayoutIn3  "LayoutIn3b.hs" "LayoutIn3b"   , mkTestModChange changeLayoutIn4  "LayoutIn4.hs"  "LayoutIn4"   , mkTestModChange changeLocToName  "LocToName.hs"  "LocToName" @@ -171,114 +185,154 @@  -- --------------------------------------------------------------------- -tt :: IO Bool-tt = do-{--    manipulateAstTest "LetExpr.hs"               "LetExpr"-    manipulateAstTest "ExprPragmas.hs"           "ExprPragmas"-    manipulateAstTest "ListComprehensions.hs"    "Main"-    manipulateAstTest "MonadComprehensions.hs"   "Main"-    manipulateAstTest "FunDeps.hs"               "Main"-    manipulateAstTest "RecursiveDo.hs"           "Main"-    manipulateAstTest "TypeFamilies.hs"          "Main"-    manipulateAstTest "MultiParamTypeClasses.hs" "Main"-    manipulateAstTest "DataFamilies.hs"          "DataFamilies"-    manipulateAstTest "Deriving.hs"              "Main"-    manipulateAstTest "Default.hs"               "Main"-    manipulateAstTest "ForeignDecl.hs"           "ForeignDecl"-    manipulateAstTest "Warning.hs"               "Warning"-    manipulateAstTest "Annotations.hs"           "Annotations"-    manipulateAstTestTH "QuasiQuote.hs"          "QuasiQuote"-    manipulateAstTest "Roles.hs"                 "Roles"-    manipulateAstTest "Splice.hs"                "Splice"-    manipulateAstTest "ImportsSemi.hs"           "ImportsSemi"-    manipulateAstTest "Stmts.hs"                 "Stmts"-    manipulateAstTest "Mixed.hs"                 "Main"-    manipulateAstTest "Arrow.hs"                 "Arrow"-    manipulateAstTest "PatSynBind.hs"            "Main"-    manipulateAstTest "HsDo.hs"                  "HsDo"-    manipulateAstTest "ForAll.hs"                "ForAll"-    manipulateAstTest "BangPatterns.hs"          "Main"-    manipulateAstTest "Associated.hs"            "Main"-    manipulateAstTest "Move1.hs"                 "Move1"-    manipulateAstTest "TypeOperators.hs"         "Main"-    manipulateAstTest "NullaryTypeClasses.hs"    "Main"-    manipulateAstTest "FunctionalDeps.hs"        "Main"-    manipulateAstTest "DerivingOC.hs"            "Main"-    manipulateAstTest "GenericDeriving.hs"       "Main"-    manipulateAstTest "OverloadedStrings.hs"     "Main"-    manipulateAstTest "RankNTypes.hs"            "Main"-    manipulateAstTest "Existential.hs"           "Main"-    manipulateAstTest "ScopedTypeVariables.hs"   "Main"-    manipulateAstTest "Arrows.hs"                "Main"-    manipulateAstTest "TH.hs"                    "Main"-    manipulateAstTest "StaticPointers.hs"        "Main"-    manipulateAstTest "DataDecl.hs"              "Main"-    manipulateAstTest "Guards.hs"                "Main"-    manipulateAstTest "RdrNames.hs"              "RdrNames"-    manipulateAstTest "Vect.hs"                  "Vect"-    manipulateAstTest "Tuple.hs"                 "Main"-    manipulateAstTest "ExtraConstraints1.hs"     "ExtraConstraints1"-    manipulateAstTest "AddAndOr3.hs"             "AddAndOr3"-    manipulateAstTest "Ann01.hs"                 "Ann01"-    manipulateAstTest "StrictLet.hs"             "Main"-    manipulateAstTest "Cg008.hs"                 "Cg008"-    manipulateAstTest "T2388.hs"                 "T2388"-    manipulateAstTest "T3132.hs"                 "T3132"-    manipulateAstTest "Stream.hs"                "Stream"-    manipulateAstTest "Trit.hs"                  "Trit"-    manipulateAstTest "DataDecl.hs"              "Main"-    manipulateAstTest "Zipper.hs"                "Zipper"-    manipulateAstTest "Sigs.hs"                  "Sigs"-    manipulateAstTest "Utils2.hs"                "Utils2"-    manipulateAstTest "EmptyMostlyInst.hs"       "EmptyMostlyInst"-    manipulateAstTest "EmptyMostlyNoSemis.hs"    "EmptyMostlyNoSemis"-    manipulateAstTest "EmptyMostly.hs"           "EmptyMostly"-    manipulateAstTest "FromUtils.hs"             "Main"-    manipulateAstTest "DocDecls.hs"              "DocDecls"-    manipulateAstTest "RecordUpdate.hs"          "Main"-    -- manipulateAstTest "Unicode.hs"               "Main"-    manipulateAstTest "B.hs"                     "Main"-    manipulateAstTest "LayoutWhere.hs"           "Main"-    manipulateAstTest "Deprecation.hs"           "Deprecation"-    manipulateAstTest "Infix.hs"                 "Main"-    manipulateAstTest "BCase.hs"                 "Main"-    manipulateAstTest "LetExprSemi.hs"           "LetExprSemi"-    manipulateAstTest "LetExpr2.hs"              "Main"-    manipulateAstTest "LetStmt.hs"               "Layout.LetStmt"-    manipulateAstTest "LayoutLet.hs"             "Main"-    manipulateAstTest "ImplicitParams.hs"        "Main"-    manipulateAstTest "RebindableSyntax.hs"      "Main"-    manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"-    manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5"-    manipulateAstTest "EmptyMostly2.hs"          "EmptyMostly2"-    manipulateAstTest "WhereIn4.hs"              "WhereIn4"-    manipulateAstTest "AltsSemis.hs"             "Main"-    manipulateAstTest "PArr.hs"                  "PArr"-    manipulateAstTest "Dead1.hs"                 "Dead1"-    manipulateAstTest "DocDecls.hs"              "DocDecls"-    manipulateAstTest "ViewPatterns.hs"          "Main"-    manipulateAstTest "LayoutLet2.hs"             "LayoutLet2"-    manipulateAstTest "FooExpected.hs"          "Main"-    manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2"-    manipulateAstTest "LayoutIn1.hs"                 "LayoutIn1"-    manipulateAstTestWithMod changeLayoutIn1  "LayoutIn1.hs" "LayoutIn1"-    manipulateAstTest "LocToName.hs"                 "LocToName"-    -}-    -- manipulateAstTestWithMod changeLayoutIn4  "LayoutIn4.hs" "LayoutIn4"-    manipulateAstTestWithMod changeLocToName  "LocToName.hs" "LocToName"-    -- manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"-    -- manipulateAstTestWithMod changeRename1    "Rename1.hs"  "Main"-    -- manipulateAstTest    "Rename1.hs"  "Main"-    -- manipulateAstTest "Rules.hs"                 "Rules"+formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO ()+formatTT (ts, fs) = do+  when (not . null $ tail ts) (do+    putStrLn "Pass"+    mapM_ (putStrLn . fst) (tail ts)+    )+  when (not . null $ fs) (do+    putStrLn "Fail"+    mapM_ (putStrLn . fst) fs) -{--    manipulateAstTest "ParensAroundContext.hs"   "ParensAroundContext"-    manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4"-    manipulateAstTest "Cpp.hs"                   "Main"-    manipulateAstTest "Lhs.lhs"                  "Main"-    manipulateAstTest "Foo.hs"                   "Main"+tt :: IO ()+tt = formatTT =<< partition snd <$> sequence [ return ("", True)+    {-+    , manipulateAstTestWFname "LetExpr.hs"               "LetExpr"+    -}+    -- , manipulateAstTestWFname "ExprPragmas.hs"           "ExprPragmas"+    {-+    , manipulateAstTestWFname "ListComprehensions.hs"    "Main"+    , manipulateAstTestWFname "MonadComprehensions.hs"   "Main"+    , manipulateAstTestWFname "FunDeps.hs"               "Main"+    , manipulateAstTestWFname "RecursiveDo.hs"           "Main"+    , manipulateAstTestWFname "TypeFamilies.hs"          "Main"+    , manipulateAstTestWFname "MultiParamTypeClasses.hs" "Main"+    , manipulateAstTestWFname "DataFamilies.hs"          "DataFamilies"+    , manipulateAstTestWFname "Deriving.hs"              "Main"+    , manipulateAstTestWFname "Default.hs"               "Main"+    , manipulateAstTestWFname "ForeignDecl.hs"           "ForeignDecl"+    , manipulateAstTestWFname "Warning.hs"               "Warning"+    -}+    -- , manipulateAstTestWFname "Annotations.hs"           "Annotations"+    {-+    , manipulateAstTestWFnameTH "QuasiQuote.hs"          "QuasiQuote"+    , manipulateAstTestWFname "Roles.hs"                 "Roles"+    , manipulateAstTestWFname "Splice.hs"                "Splice"+    , manipulateAstTestWFname "ImportsSemi.hs"           "ImportsSemi"+    , manipulateAstTestWFname "Stmts.hs"                 "Stmts"+    -}+    -- , manipulateAstTestWFname "Mixed.hs"                 "Main"+    {-+    , manipulateAstTestWFname "Arrow.hs"                 "Arrow"+    , manipulateAstTestWFname "PatSynBind.hs"            "Main"+    -}+    -- , manipulateAstTestWFname "HsDo.hs"                  "HsDo"+    {-+    , manipulateAstTestWFname "ForAll.hs"                "ForAll"+    , manipulateAstTestWFname "BangPatterns.hs"          "Main"+    , manipulateAstTestWFname "Associated.hs"            "Main"+    -}+    -- , manipulateAstTestWFname "Move1.hs"                 "Move1"+    {-+    , manipulateAstTestWFname "TypeOperators.hs"         "Main"+    ,  manipulateAstTestWFname "NullaryTypeClasses.hs"    "Main"+    , manipulateAstTestWFname "FunctionalDeps.hs"        "Main"+    , manipulateAstTestWFname "DerivingOC.hs"            "Main"+    , manipulateAstTestWFname "GenericDeriving.hs"       "Main"+    , manipulateAstTestWFname "OverloadedStrings.hs"     "Main"+    , manipulateAstTestWFname "RankNTypes.hs"            "Main"+    -}+    -- , manipulateAstTestWFname "Existential.hs"           "Main"+    {-+    , manipulateAstTestWFname "ScopedTypeVariables.hs"   "Main"+    , manipulateAstTestWFname "Arrows.hs"                "Main"+    , manipulateAstTestWFname "TH.hs"                    "Main"+    , manipulateAstTestWFname "StaticPointers.hs"        "Main"+    , manipulateAstTestWFname "DataDecl.hs"              "Main"+    , manipulateAstTestWFname "Guards.hs"                "Main"+    , manipulateAstTestWFname "RdrNames.hs"              "RdrNames"+    -}+    -- , manipulateAstTestWFname "Vect.hs"                  "Vect"+    {-+    , manipulateAstTestWFname "Tuple.hs"                 "Main"+    , manipulateAstTestWFname "ExtraConstraints1.hs"     "ExtraConstraints1"+    , manipulateAstTestWFname "AddAndOr3.hs"             "AddAndOr3"+    -}+    -- , manipulateAstTestWFname "Ann01.hs"                 "Ann01"+    -- , manipulateAstTestWFname "StrictLet.hs"             "Main"+    {-+    , manipulateAstTestWFname "Cg008.hs"                 "Cg008"+    , manipulateAstTestWFname "T2388.hs"                 "T2388"+    , manipulateAstTestWFname "T3132.hs"                 "T3132"+    , manipulateAstTestWFname "Stream.hs"                "Stream"+    , manipulateAstTestWFname "Trit.hs"                  "Trit"+    , manipulateAstTestWFname "DataDecl.hs"              "Main"+    , manipulateAstTestWFname "Zipper.hs"                "Zipper"+    -}+    -- , manipulateAstTestWFname "Sigs.hs"                  "Sigs"+    -- , manipulateAstTestWFname "Utils2.hs"                "Utils2"+    {-+    , manipulateAstTestWFname "EmptyMostlyInst.hs"       "EmptyMostlyInst"+    , manipulateAstTestWFname "EmptyMostlyNoSemis.hs"    "EmptyMostlyNoSemis"+    , manipulateAstTestWFname "EmptyMostly.hs"           "EmptyMostly"+    , manipulateAstTestWFname "FromUtils.hs"             "Main"+    , manipulateAstTestWFname "DocDecls.hs"              "DocDecls"+    , manipulateAstTestWFname "RecordUpdate.hs"          "Main"+    -- manipulateAstTestWFname "Unicode.hs"               "Main"+    , manipulateAstTestWFname "B.hs"                     "Main"+    , manipulateAstTestWFname "LayoutWhere.hs"           "Main"+    -}+    -- , manipulateAstTestWFname "Deprecation.hs"           "Deprecation"+    {-+    , manipulateAstTestWFname "Infix.hs"                 "Main"+    , manipulateAstTestWFname "BCase.hs"                 "Main"+    , manipulateAstTestWFname "LetExprSemi.hs"           "LetExprSemi"+    , manipulateAstTestWFname "LetExpr2.hs"              "Main"+    , manipulateAstTestWFname "LetStmt.hs"               "Layout.LetStmt"+    , manipulateAstTestWFname "LayoutLet.hs"             "Main"+    -}+    -- , manipulateAstTestWFname "ImplicitParams.hs"        "Main"+    {-+    , manipulateAstTestWFname "RebindableSyntax.hs"      "Main"+    , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"+    , manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5"+    , manipulateAstTestWFname "EmptyMostly2.hs"          "EmptyMostly2"+    , manipulateAstTestWFname "WhereIn4.hs"              "WhereIn4"+    , manipulateAstTestWFname "AltsSemis.hs"             "Main"+    , manipulateAstTestWFname "PArr.hs"                  "PArr"+    -}+    -- , manipulateAstTestWFname "Dead1.hs"                 "Dead1"+    {-+    , manipulateAstTestWFname "DocDecls.hs"              "DocDecls"+    , manipulateAstTestWFname "ViewPatterns.hs"          "Main"+    , manipulateAstTestWFname "FooExpected.hs"          "Main"+    , manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2"+    , manipulateAstTestWFname "LayoutIn1.hs"                 "LayoutIn1"+    , manipulateAstTestWithMod changeLayoutIn1  "LayoutIn1.hs" "LayoutIn1"+    , manipulateAstTestWFname "LocToName.hs"                 "LocToName"+    , manipulateAstTestWithMod changeLayoutIn4  "LayoutIn4.hs" "LayoutIn4"+    , manipulateAstTestWithMod changeLocToName  "LocToName.hs" "LocToName"+    , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"+    , manipulateAstTestWithMod changeRename1    "Rename1.hs"  "Main"+    , manipulateAstTestWFname    "Rename1.hs"  "Main"+    -}+    -- , manipulateAstTestWFname "Rules.hs"                 "Rules"+    -- , manipulateAstTestWFname "LayoutLet2.hs"             "LayoutLet2"+    -- , manipulateAstTestWFname "LayoutIn3.hs"             "LayoutIn3"+    -- , manipulateAstTestWFname "LayoutIn3a.hs"             "LayoutIn3a"+    , manipulateAstTestWFnameMod changeLayoutIn3  "LayoutIn3a.hs" "LayoutIn3a"+    -- , manipulateAstTestWFnameMod changeLayoutIn3  "LayoutIn3b.hs" "LayoutIn3b"+    -- , manipulateAstTestWFnameMod changeLayoutIn3  "LayoutIn3.hs" "LayoutIn3"+    -- , manipulateAstTestWFname "LayoutLet2.hs"             "LayoutLet2"+    {-+    , manipulateAstTestWFname "ParensAroundContext.hs"   "ParensAroundContext"+    , manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4"+    , manipulateAstTestWFname "Cpp.hs"                   "Main"+    , manipulateAstTestWFname "Lhs.lhs"                  "Main"+    , manipulateAstTestWFname "Foo.hs"                   "Main" -}+    ]  -- --------------------------------------------------------------------- @@ -288,6 +342,10 @@ changeLocToName :: GHC.ParsedSource -> GHC.ParsedSource changeLocToName parsed = rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed +changeLayoutIn3 :: GHC.ParsedSource -> GHC.ParsedSource+changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed+-- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed+ changeLayoutIn4 :: GHC.ParsedSource -> GHC.ParsedSource changeLayoutIn4 parsed = rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed @@ -354,9 +412,17 @@ manipulateAstTestWithMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO Bool manipulateAstTestWithMod change file modname = manipulateAstTest' (Just change) False file modname +manipulateAstTestWFnameMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO (FilePath,Bool)+manipulateAstTestWFnameMod change fileName modname+  = do r <- manipulateAstTestWithMod change fileName modname+       return (fileName,r)+ manipulateAstTest :: FilePath -> String -> IO Bool manipulateAstTest file modname = manipulateAstTest' Nothing False file modname +manipulateAstTestWFname :: FilePath -> String -> IO (FilePath, Bool)+manipulateAstTestWFname file modname = (file,) <$> manipulateAstTest file modname+ manipulateAstTestTH :: FilePath -> String -> IO Bool manipulateAstTestTH file modname = manipulateAstTest' Nothing True file modname @@ -377,13 +443,13 @@     -- parsedAST = showGhc parsed        -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule)))     -- try to pretty-print; summarize the test result-    ann = annotateAST parsed ghcAnns+    ann = relativiseApiAnns parsed ghcAnns       `debug` ("ghcAnns:" ++ showGhc ghcAnns)      parsed' = case mchange of                    Nothing -> parsed                    Just change -> change parsed-    printed = exactPrintAnnotation parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))+    printed = exactPrintWithAnns parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))     result =             if printed == contents               then "Match\n"@@ -395,7 +461,9 @@   writeFile out $ result   -- putStrLn $ "Test:parsed=" ++ parsedAST   -- putStrLn $ "Test:ann :" ++ showGhc ann+  -- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns   -- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed+  -- putStrLn $ "Test:showdata:parsed'" ++ SYB.showData SYB.Parser 0 parsed'   -- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed'   return ("Match\n" == result) @@ -550,4 +618,3 @@        case Map.lookup tmp_dir mapping of            Nothing -> error "should already be a tmpDir"            Just d -> return d-
+ tests/examples/AddAndOr3.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PartialTypeSignatures #-}+module AddAndOr3 where++addAndOr3 :: _ -> _ -> _+addAndOr3 (a, b) (c, d) = (a `plus` d, b || c)+  where plus :: Int -> Int -> Int+        x `plus` y = x + y
+ tests/examples/AltsSemis.hs view
@@ -0,0 +1,11 @@+++foo x =+  case x of+   { ;;; -- leading+     0 -> 'a';  -- case 0+     1 -> 'b'   -- case 1+   ; 2 -> 'c' ; -- case 2+   ; 3 -> 'd'   -- case 3+          ;;;   -- case 4+   }
+ tests/examples/Ann01.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}++module Ann01 where++{-# ANN module (1 :: Int) #-}+{-# ANN module (1 :: Integer) #-}+{-# ANN module (1 :: Double) #-}+{-# ANN module $([| 1 :: Int |]) #-}+{-# ANN module "Hello" #-}+{-# ANN module (Just (1 :: Int)) #-}+{-# ANN module [1 :: Int, 2, 3] #-}+{-# ANN module ([1..10] :: [Integer]) #-}+{-# ANN module ''Foo #-}+{-# ANN module (-1 :: Int) #-}++{-# ANN type Foo (1 :: Int) #-}+{-# ANN type Foo (1 :: Integer) #-}+{-# ANN type Foo (1 :: Double) #-}+{-# ANN type Foo $([| 1 :: Int |]) #-}+{-# ANN type Foo "Hello" #-}+{-# ANN type Foo (Just (1 :: Int)) #-}+{-# ANN type Foo [1 :: Int, 2, 3] #-}+{-# ANN type Foo ([1..10] :: [Integer]) #-}+{-# ANN type Foo ''Foo #-}+{-# ANN type Foo (-1 :: Int) #-}+data Foo = Bar Int++{-# ANN f (1 :: Int) #-}+{-# ANN f (1 :: Integer) #-}+{-# ANN f (1 :: Double) #-}+{-# ANN f $([| 1 :: Int |]) #-}+{-# ANN f "Hello" #-}+{-# ANN f (Just (1 :: Int)) #-}+{-# ANN f [1 :: Int, 2, 3] #-}+{-# ANN f ([1..10] :: [Integer]) #-}+{-# ANN f 'f #-}+{-# ANN f (-1 :: Int) #-}+f x = x
+ tests/examples/Annotations.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}++module Annotations where++{-# ANN module (1 :: Int) #-}+{-# ANN module (1 :: Integer) #-}+{-# ANN module (1 :: Double) #-}+{-# ANN module $([| 1 :: Int |]) #-}+{-# ANN module "Hello" #-}+{-# ANN module (Just (1 :: Int)) #-}+{-# ANN module [1 :: Int, 2, 3] #-}+{-# ANN module ([1..10] :: [Integer]) #-}+{-# ANN module ''Foo #-}+{-# ANN module (-1 :: Int) #-}++{-# ANN type Foo (1 :: Int) #-}+{-# ANN type Foo (1 :: Integer) #-}+{-# ANN type Foo (1 :: Double) #-}+{-# ANN type Foo $([| 1 :: Int |]) #-}+{-# ANN type Foo "Hello" #-}+{-# ANN type Foo (Just (1 :: Int)) #-}+{-# ANN type Foo [1 :: Int, 2, 3] #-}+{-# ANN type Foo ([1..10] :: [Integer]) #-}+{-# ANN type Foo ''Foo #-}+{-# ANN type Foo (-1 :: Int) #-}+data Foo = Bar Int++{-# ANN f (1 :: Int) #-}+{-# ANN f (1 :: Integer) #-}+{-# ANN f (1 :: Double) #-}+{-# ANN f $([| 1 :: Int |]) #-}+{-# ANN f "Hello" #-}+{-# ANN f (Just (1 :: Int)) #-}+{-# ANN f [1 :: Int, 2, 3] #-}+{-# ANN f ([1..10] :: [Integer]) #-}+{-# ANN f 'f #-}+{-# ANN f (-1 :: Int) #-}+f x = x
+ tests/examples/Arrow.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE Arrows #-}+module Arrow where++import Control.Arrow+import qualified Control.Category as Cat++addA :: Arrow a => a b Int -> a b Int -> a b Int+addA f g = proc x -> do+                y <- f -< x+                z <- g -< x+                returnA -< y + z++newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) }++instance Cat.Category Circuit where+    id = Circuit $ \a -> (Cat.id, a)+    (.) = dot+      where+        (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a ->+            let (cir1', b) = cir1 a+                (cir2', c) = cir2 b+            in  (cir2' `dot` cir1', c)++instance Arrow Circuit where+    arr f = Circuit $ \a -> (arr f, f a)+    first (Circuit cir) = Circuit $ \(b, d) ->+        let (cir', c) = cir b+        in  (first cir', (c, d))++-- | Accumulator that outputs a value determined by the supplied function.+accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b+accum acc f = Circuit $ \input ->+    let (output, acc') = input `f` acc+    in  (accum acc' f, output)++-- | Accumulator that outputs the accumulator value.+accum' :: b -> (a -> b -> b) -> Circuit a b+accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))++total :: Num a => Circuit a a+total = accum' 0 (+)++mean3 :: Fractional a => Circuit a a+mean3 = proc value -> do+    (t, n) <- (| (&&&) (total -< value) (total -< 1) |)+    returnA -< t / n
+ tests/examples/Arrows.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Arrows #-}+-- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html++import Control.Monad (guard)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli)++f :: Int -> (Int, Int)+f = \x ->+  let y  = 2 * x+      z1 = y + 3+      z2 = y - 5+  in (z1, z2)++-- ghci> f 10+-- (23, 15)++fM :: Int -> Identity (Int, Int)+fM = \x -> do+  y  <- return (2 * x)+  z1 <- return (y + 3)+  z2 <- return (y - 5)+  return (z1, z2)++-- ghci> runIdentity (fM 10)+-- (23,15)+++fA :: Int -> (Int, Int)+fA = proc x -> do+  y  <- (2 *) -< x+  z1 <- (+ 3) -< y+  z2 <- (subtract 5) -< y+  returnA -< (z1, z2)++-- ghci> fA 10+-- (23,15)++range :: Int -> [Int]+range r = [-r..r]++cM :: Int -> [(Int, Int)]+cM = \r -> do+  x <- range 5+  y <- range 5+  guard (x*x + y*y <= r*r)+  return (x, y)++-- ghci> take 10 (cM 5)+-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)]+++type K = Kleisli++k :: (a -> m b) -> Kleisli m a b+k = Kleisli++runK :: Kleisli m a b -> (a -> m b)+runK = runKleisli++cA :: Kleisli [] Int (Int, Int)+cA = proc r -> do+  x <- k range -< 5+  y <- k range -< 5+  k guard -< (x*x + y*y <= r*r)+  returnA -< (x, y)++-- ghci> take 10 (runK cA 5)+-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)]++getLineM :: String -> IO String+getLineM prompt = do+  print prompt+  getLine++printM :: String -> IO ()+printM = print++writeFileM :: (FilePath, String) -> IO ()+writeFileM  (filePath, string) = writeFile filePath string++procedureM :: String -> IO ()+procedureM = \prompt -> do+  input <- getLineM prompt+  if input == "Hello"+    then printM "You said 'Hello'"+    else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'")
+ tests/examples/Associated.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}++-- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example++import qualified Data.IntMap+import Prelude hiding (lookup)+import Data.Char (ord)++class GMapKey k where+  data GMap k :: * -> *+  empty       :: GMap k v+  lookup      :: k -> GMap k v -> Maybe v+  insert      :: k -> v -> GMap k v -> GMap k v++-- An Int instance+instance GMapKey Int where+  data GMap Int v        = GMapInt (Data.IntMap.IntMap v)+  empty                  = GMapInt Data.IntMap.empty+  lookup k   (GMapInt m) = Data.IntMap.lookup k m+  insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m)++-- A Char instance+instance GMapKey Char where+  data GMap Char v        = GMapChar (GMap Int v)+  empty                   = GMapChar empty+  lookup k (GMapChar m)   = lookup (ord k) m+  insert k v (GMapChar m) = GMapChar (insert (ord k) v m)++-- A Unit instance+instance GMapKey () where+  data GMap () v           = GMapUnit (Maybe v)+  empty                    = GMapUnit Nothing+  lookup () (GMapUnit v)   = v+  insert () v (GMapUnit _) = GMapUnit $ Just v++-- Product and sum instances+instance (GMapKey a, GMapKey b) => GMapKey (a, b) where+  data GMap (a, b) v            = GMapPair (GMap a (GMap b v))+  empty                         = GMapPair empty+  lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b+  insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of+                                    Nothing  -> insert a (insert b v empty) gm+                                    Just gm2 -> insert a (insert b v gm2  ) gm++instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where+  data GMap (Either a b) v                = GMapEither (GMap a v) (GMap b v)+  empty                                   = GMapEither empty empty+  lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1+  lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2+  insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2+  insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2)++myGMap :: GMap (Int, Either Char ()) String+myGMap = insert (5, Left 'c') "(5, Left 'c')"    $+         insert (4, Right ()) "(4, Right ())"    $+         insert (5, Right ()) "This is the one!" $+         insert (5, Right ()) "This is the two!" $+         insert (6, Right ()) "(6, Right ())"    $+         insert (5, Left 'a') "(5, Left 'a')"    $+         empty++main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap++-- (Type) Synonym Family++type family Elem c++type instance Elem [e] = e++-- type instance Elem BitSet = Char+++data family T a+data    instance T Int  = T1 Int | T2 Bool+newtype instance T Char = TC Bool++data family G a b+data instance G [a] b where+   G1 :: c -> G [Int] b+   G2 :: G [a] Bool
+ tests/examples/B.hs view
@@ -0,0 +1,4 @@++foo x = case (odd x) of+            True  -> "Odd"+            False -> "Even"
+ tests/examples/BCase.hs view
@@ -0,0 +1,8 @@+++main =+ case 1 > 10 of+   True  -> do putStrLn "hello"+               putStrLn "there"+   False -> do putStrLn "blah"+               putStrLn "blah"
+ tests/examples/BIf.hs view
@@ -0,0 +1,8 @@+++main =+ if 1 > 10+   then do putStrLn "hello"+           putStrLn "there"+   else do putStrLn "blah"+           putStrLn "blah"
+ tests/examples/BangPatterns.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE BangPatterns #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html++import Data.Function (fix)+import Data.List (foldl')++hello3 :: Bool -> String+hello3 !loud = "Hello."++mean :: [Double] -> Double+mean xs = s / fromIntegral l+  where+    (s, l) = foldl' step (0, 0) xs+    step (!s, !l) a = (s + a, l + 1)+
+ tests/examples/BootImport.hs view
@@ -0,0 +1,3 @@+module BootImport where++data Foo = Foo Int
+ tests/examples/BootImport.hs-boot view
@@ -0,0 +1,3 @@+module BootImport where++data Foo
+ tests/examples/Cg008.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE MagicHash, BangPatterns #-}+{-# OPTIONS_GHC -O0 #-}++-- Variant of cgrun066; compilation as a module is different.++module Cg008 (hashStr) where++import Foreign.C+import Data.Word+import Foreign.Ptr+import GHC.Exts++import Control.Exception++hashStr  :: Ptr Word8 -> Int -> Int+hashStr (Ptr a#) (I# len#) = loop 0# 0#+   where+    loop h n | isTrue# (n GHC.Exts.==# len#) = I# h+             | otherwise  = loop h2 (n GHC.Exts.+# 1#)+          where !c = ord# (indexCharOffAddr# a# n)+                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091#
+ tests/examples/Cpp.hs view
@@ -0,0 +1,9 @@+{-# Language CPP #-}++#if __GLASGOW_HASKELL__ > 704+foo :: Int+#else+foo :: Integer+#endif+foo = 3+
+ tests/examples/DataDecl.hs view
@@ -0,0 +1,34 @@+{-# Language DatatypeContexts #-}+{-# Language ExistentialQuantification #-}+{-# LAnguage GADTs #-}+{-# LAnguage KindSignatures #-}++data Foo = A+         | B+         | C++--         | data_or_newtype capi_ctype tycl_hdr constrs deriving+data {-# Ctype "Foo" "bar" #-} F1 = F1+data {-# Ctype       "baz" #-} Eq a =>  F2 a = F2 a++data (Eq a,Ord a) => F3 a = F3 Int a++data F4 a = forall x y. (Eq x,Eq y) => F4 a x y+          | forall x y. (Eq x,Eq y) => F4b a x y+++data G1 a :: * where+  G1A,  G1B :: Int -> G1 a+  G1C :: Double -> G1 a++data G2 a :: * where+  G2A { g2a :: a, g2b :: Int } :: G2 a+  G2C :: Double -> G2 a++++data (Eq a,Ord a) => G3 a = G3+  { g3A :: Int+  , g3B :: Bool+  , g3a :: a+  } deriving (Eq,Ord)
+ tests/examples/DataFamilies.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families++module DataFamilies+  (+    GMap+  , GMapKey(type GMapK)+  ) where++-- Type 1, Top level++data family GMap k :: * -> *++data family Array e++data family ArrayK :: * -> *+++-- Type 2, associated types++class GMapKey k where+  data GMapK k :: * -> *++class C a b c where { data T1 c a :: * }  -- OK+-- class C a b c where { data T a a :: * }  -- Bad: repeated variable+-- class D a where { data T a x :: * }      -- Bad: x is not a class variable+class D a where { data T2 a :: * -> * }   -- OK++-- Instances++data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)++data family T3 a+data instance T3 Int  = A+data instance T3 Char = B+nonsense :: T3 a -> Int+-- nonsense A = 1             -- WRONG: These two equations together...+-- nonsense B = 2             -- ...will produce a type error.+nonsense = undefined+++instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where+  data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v)++-- data GMap () v = GMapUnit (Maybe v)+--               deriving Show++
+ tests/examples/Dead1.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-}++module Dead1(foo) where++foo :: Int -> Int+foo n = baz (n+1) (bar1 n)++{-# NOINLINE bar1 #-}+bar1 n = 1 + bar n++bar :: Int -> Int+{-# NOINLINE bar #-}+{-# RULES+"bar/foo" forall n. bar (foo n) = n+   #-}+bar n = n-1++baz :: Int -> Int -> Int+{-# INLINE [0] baz #-}+baz m n = m+++{- Ronam writes (Feb08)++    Note that bar becomes dead as soon as baz gets inlined. But strangely,+    the simplifier only deletes it after full laziness and CSE. That is, it+    is not deleted in the phase in which baz gets inlined. In fact, it is+    still there after w/w and the subsequent simplifier run. It gets deleted+    immediately if I comment out the rule.++    I stumbled over this when I removed one simplifier run after SpecConstr+    (at the moment, it runs twice at the end but I don't think that should+    be necessary). With this change, the original version of a specialised+    loop (the one with the rules) is not longer deleted even if it isn't+    used any more. I'll reenable the second simplifier run for now but+    should this really be necessary?++No, it should not be necessary.  A refactoring in OccurAnal makes+this work right. Look at the simplifier output just before strictness+analysis; there should be a binding for 'foo', but for nothing else.++-}
+ tests/examples/Default.hs view
@@ -0,0 +1,8 @@+default (Integer, Double) -- "default default"++mag :: Float -> Float -> Float+mag x y = sqrt( x^2 + y^2 )++main = do++print $ mag 1 1
+ tests/examples/Deprecation.hs view
@@ -0,0 +1,14 @@++module Deprecation+{-# Deprecated ["This is a module \"deprecation\"",+             "multi-line"] #-}+   ( foo )+ where++{-# DEPRECATEd   foo+         ["This is a multi-line",+          "deprecation message",+          "for foo"] #-}+foo :: Int+foo = 4+
+ tests/examples/Deriving.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++import Data.Data++data Foo = FooA | FooB++deriving instance Show Foo++deriving instance {-# Overlappable #-} Eq Foo+deriving instance {-# Overlapping  #-} Ord Foo+deriving instance {-# Overlaps     #-} Typeable Foo+deriving instance {-# Incoherent   #-} Data Foo+
+ tests/examples/DerivingOC.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html++import Data.Data+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State++data MiniIoF a = Terminate+               | PrintLine String a+               | ReadLine (String -> a)+               deriving (Functor)+++-- data List a = Nil | Cons a (List a)+--               deriving (Eq, Show, Functor, Foldable, Traversable)++++data List a = Nil | Cons a (List a)+              deriving ( Eq, Show+                       , Functor, Foldable, Traversable+                       , Typeable, Data)++data Config = C String String+data AppState = S Int Bool++newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a }+                deriving (Monad, MonadReader Config,+                          MonadState AppState, MonadIO,+                          Applicative,Functor)
+ tests/examples/DocDecls.hs view
@@ -0,0 +1,7 @@+module DocDecls where++-- | A document before+data Foo = A Int | B Char+         deriving (Show)++
+ tests/examples/EmptyMostly.hs view
@@ -0,0 +1,13 @@+module EmptyMostly where+   { ;;;+     ;;x=let{;;;;;y=2;;z=3;;;;}in y;+   -- ;;;;+    class Foo a where {;;;;;;+  (--<>--) :: a -> a -> Int  ;+  infixl 5 --<>-- ;+  (--<>--) _ _ = 2 ; -- empty decl at the end.+};+-- ;;;;;;;;;;;;+-- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;}+-- ;;+   }
+ tests/examples/EmptyMostly2.hs view
@@ -0,0 +1,8 @@+module EmptyMostly2 where+   {+;;;;;;;;;;;;+;+class Baz a where {;;;;;;;;;+ ; baz :: a -> Int;;;+}+   }
+ tests/examples/EmptyMostlyInst.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE FlexibleInstances #-}+module EmptyMostlyInst where+   {+;;;;;;;;;;;;+;+instance Eq (Int,Integer) where {;;;;;;;;;+;;;;;;; a == b = False;;;;;;;;;;;+}+   }
+ tests/examples/EmptyMostlyNoSemis.hs view
@@ -0,0 +1,8 @@+module EmptyMostlyNoSemis where++x=let{y=2}in y+class Foo a where {+  (--<>--) :: a -> a -> Int;+  infixl 5 --<>--;+  (--<>--) _ _ = 2 ; -- empty decl at the end.+ }
+ tests/examples/Existential.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html++data HashMap k v = HM  -- ... -- actual implementation++class Hashable v where+  h :: v -> Int++data HashMapM hm = HashMapM+  { empty  :: forall k v . hm k v+  , lookup :: Hashable k => k -> hm k v -> Maybe v+  , insert :: Hashable k => k -> v -> hm k v -> hm k v+  , union  :: Hashable k => hm k v -> hm k v -> hm k v+  }+++data HashMapE = forall hm . HashMapE (HashMapM hm)++-- public+mkHashMapE :: Int -> HashMapE+mkHashMapE = HashMapE . mkHashMapM++-- private+mkHashMapM :: Int -> HashMapM HashMap+mkHashMapM salt = HashMapM { {- implementation -} }++instance Hashable String where++type Name = String+data Gift = G String++giraffe :: Gift+giraffe = G "giraffe"++addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift+addGift mod gifts =+  let+    HashMapM{..} = mod+  in+    insert "Ollie" giraffe gifts++-- -------------------------------++santa'sSecretSalt = undefined+sendGiftToOllie = undefined+traverse_ = undefined++sendGifts =+  case mkHashMapE santa'sSecretSalt of+    HashMapE (mod@HashMapM{..}) ->+      let+        gifts = addGift mod empty+      in+        traverse_ sendGiftToOllie $ lookup "Ollie" gifts
+ tests/examples/Expr.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Expr where++import Data.Generics+import Language.Haskell.TH as TH+import Language.Haskell.TH.Quote++-- import Text.ParserCombinators.Parsec+-- import Text.ParserCombinators.Parsec.Char++data Expr  =  IntExpr Integer+           |  AntiIntExpr String+           |  BinopExpr BinOp Expr Expr+           |  AntiExpr String+    deriving(Typeable, Data,Show)++data BinOp  =  AddOp+            |  SubOp+            |  MulOp+            |  DivOp+    deriving(Typeable, Data,Show)++eval :: Expr -> Integer+eval (IntExpr n)        = n+eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)+  where+    opToFun AddOp = (+)+    opToFun SubOp = (-)+    opToFun MulOp = (*)+    opToFun DivOp = (div)++small   = lower <|> char '_'+large   = upper+idchar  = small <|> large <|> digit <|> char '\''++lexeme p    = do{ x <- p; spaces; return x  }+symbol name = lexeme (string name)+parens p    = undefined -- between (symbol "(") (symbol ")") p++_expr :: CharParser st Expr+_expr   = term   `chainl1` mulop++term :: CharParser st Expr+term    = factor `chainl1` addop++factor :: CharParser st Expr+factor  = parens _expr <|> integer <|> anti++mulop   =  undefined+{-+           do{ symbol "*"; return $ BinopExpr MulOp }+        <|> do{ symbol "/"; return $ BinopExpr DivOp }+-}+addop   = undefined+{-+  do{ symbol "+"; return $ BinopExpr AddOp }+        <|> do{ symbol "-"; return $ BinopExpr SubOp }+-}++integer :: CharParser st Expr+integer  = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }++anti   = undefined+{-+  lexeme $+         do  symbol "$"+             c <- small+             cs <- many idchar+             return $ AntiIntExpr (c : cs)+-}++parseExpr :: Monad m => TH.Loc -> String -> m Expr+parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =+    case runParser p () "" s of+      Left err  -> fail $ "baz"+      Right e   -> return e+  where+    p = do  pos <- getPosition+            setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file+            spaces+            e <- _expr+            eof+            return e++expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat }++parseExprExp :: String -> Q Exp+parseExprExp s =  do  loc <- location+                      expr <- parseExpr loc s+                      dataToExpQ (const Nothing `extQ` antiExprExp) expr++antiExprExp :: Expr -> Maybe (Q Exp)+antiExprExp  (AntiIntExpr v)  = Just $ appE  (conE (mkName "IntExpr"))+                                                (varE (mkName v))+antiExprExp  (AntiExpr v)     = Just $ varE  (mkName v)+antiExprExp  _                = Nothing++parseExprPat :: String -> Q Pat+parseExprPat s =  do  loc <- location+                      expr <- parseExpr loc s+                      dataToPatQ (const Nothing `extQ` antiExprPat) expr++antiExprPat :: Expr -> Maybe (Q Pat)+antiExprPat  (AntiIntExpr v)  = Just $ conP  (mkName "IntExpr")+                                                [varP (mkName v)]+antiExprPat  (AntiExpr v)     = Just $ varP  (mkName v)+antiExprPat  _                = Nothing++-- keep parser happy+runParser = undefined+getPosition = undefined+setPosition = undefined+setSourceName = undefined+setSourceLine = undefined+setSourceColumn = undefined+spaces = undefined+eof = undefined+many = undefined+digit = undefined+many1 = undefined+data CharParser a b = F a b+(<|>) = undefined+chainl1 = undefined+string = undefined+char = undefined+lower = undefined+upper = undefined+between = undefined+instance Monad (CharParser a) where+instance Applicative (CharParser a) where+instance Functor (CharParser a) where+
+ tests/examples/ExprPragmas.hs view
@@ -0,0 +1,7 @@+module ExprPragmas where++a = {-# SCC "name"   #-}  0x5++b = {-# SCC foo   #-} 006++c = {-# GENERATED "foobar" 1 : 2  -  3 :   4 #-} 0.00
+ tests/examples/ExtraConstraints1.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE PartialTypeSignatures #-}+module ExtraConstraints1 where++arbitCs1 :: _ => a -> String+arbitCs1 x = show (succ x) ++ show (x == x)++arbitCs2 :: (Show a, _) => a -> String+arbitCs2 x = arbitCs1 x++arbitCs3 :: (Show a, Enum a, _) => a -> String+arbitCs3 x = arbitCs1 x++arbitCs4 :: (Eq a, _) => a -> String+arbitCs4 x = arbitCs1 x++arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String+arbitCs5 x = arbitCs1 x
+ tests/examples/Foo.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE RecursiveDo #-}++bar :: IO ()+bar = do+  rec {}+  return ()+
+ tests/examples/FooExpected.hs view
@@ -0,0 +1,8 @@+++main =+ case 1 > 10 of+   True  -> do putStrLn "hello"+               putStrLn "there"+   False -> do putStrLn "blah"+               putStrLn "blah"
+ tests/examples/ForAll.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE RankNTypes #-}+module ForAll where++import Data.Data++foo ::  (forall a. Data a => a -> a) -> forall a. Data a => a -> a+foo a = a
+ tests/examples/ForeignDecl.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-- Based on ghc/testsuite/tests/ffi/should_compile contents+module ForeignDecl where++import Foreign+import GHC.Exts+import Data.Int+import Data.Word++-- simple functions++foreign import ccall unsafe "a" a :: IO Int++foreign import ccall unsafe "b" b :: Int -> IO Int++foreign import ccall unsafe "c"+  c :: Int -> Char -> Float -> Double -> IO Float++-- simple monadic code++d =     a               >>= \ x ->+        b x             >>= \ y ->+        c y 'f' 1.0 2.0++-- We can't import the same function using both stdcall and ccall+-- calling conventions in the same file when compiling via C (this is a+-- restriction in the C backend caused by the need to emit a prototype+-- for stdcall functions).+foreign import stdcall        "p" m_stdcall :: StablePtr a -> IO (StablePtr b)+foreign import ccall   unsafe "q" m_ccall   :: ByteArray# -> IO Int++-- We can't redefine the calling conventions of certain functions (those from+-- math.h).+foreign import stdcall "my_sin" my_sin :: Double -> IO Double+foreign import stdcall "my_cos" my_cos :: Double -> IO Double++foreign import stdcall "m1" m8  :: IO Int8+foreign import stdcall "m2" m16 :: IO Int16+foreign import stdcall "m3" m32 :: IO Int32+foreign import stdcall "m4" m64 :: IO Int64++foreign import stdcall "dynamic" d8  :: FunPtr (IO Int8) -> IO Int8+foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16+foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32+foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64++foreign import ccall unsafe "kitchen"+   sink :: Ptr a+        -> ByteArray#+        -> MutableByteArray# RealWorld+        -> Int+        -> Int8+        -> Int16+        -> Int32+        -> Int64+        -> Word8+        -> Word16+        -> Word32+        -> Word64+        -> Float+        -> Double+        -> IO ()+++type Sink2 b = Ptr b+            -> ByteArray#+            -> MutableByteArray# RealWorld+            -> Int+            -> Int8+            -> Int16+            -> Int32+            -> Word8+            -> Word16+            -> Word32+            -> Float+            -> Double+            -> IO ()++foreign import ccall unsafe "dynamic"+  sink2 :: Ptr (Sink2 b) -> Sink2 b++-- exports+foreign export ccall "plusInt" (+) :: Int -> Int -> Int
+ tests/examples/FromUtils.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++import Data.Data+++-- ---------------------------------------------------------------------++instance AnnotateP RdrName where+  annotateP l n = do+    case rdrName2String n of+      "[]" -> do+        addDeltaAnnotation AnnOpenS -- '['+        addDeltaAnnotation AnnCloseS -- ']'++-- ---------------------------------------------------------------------++class (Typeable ast) => AnnotateP ast where+  annotateP :: SrcSpan -> ast -> IO ()+++type SrcSpan = Int+rdrName2String = undefined+type RdrName = String++data A = AnnOpenS | AnnCloseS++addDeltaAnnotation = undefined
+ tests/examples/FunDeps.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE FunctionalDependencies #-}++-- FunDeps example+class Foo a b c | a b -> c where+  bar :: a -> b -> c+
+ tests/examples/FunctionalDeps.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html++import Data.Foldable (forM_)+import Data.IORef++class Store store m | store -> m where+ new :: a -> m (store a)+ get :: store a -> m a+ put :: store a -> a -> m ()++instance Store IORef IO where+  new = newIORef+  get = readIORef+  put ioref a = modifyIORef ioref (const a)+
+ tests/examples/GenericDeriving.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+import GHC.Generics++-- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html++data Valid e a = Error e | OK a+  deriving (Generic)++toEither :: Valid e a -> Either e a+toEither (Error e) = Left e+toEither (OK a) = Right a++fromEither :: Either e a -> Valid e a+fromEither (Left e) = Error e+fromEither (Right a) = OK a++-- ---------------------------------------------------------------------++class GetError rep e | rep -> e where+  getError' :: rep a -> Maybe e++instance GetError f e => GetError (M1 i c f) e where+  getError' (M1 m1) = getError' m1++instance GetError l e => GetError (l :+: r) e where+  getError' (L1 l) = getError' l+  getError' (R1 _) = Nothing++instance GetError (K1 i e) e where+  getError' (K1 e) = Just e++getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e+getError = getError' . from+
+ tests/examples/Guards.hs view
@@ -0,0 +1,6 @@+++f x | x > 0, x /= 10 = 1 / x+    | x == 0 = undefined+  where+    y = 4
+ tests/examples/HsDo.hs view
@@ -0,0 +1,22 @@+module HsDo where++import qualified Data.Map as Map++moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)+  where+    numbered_summaries = zip summaries [1..]++    node_map :: NodeMap SummaryNode+    node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)+                            | node@(s, _, _) <- nodes ]+++graphFromEdgedVertices = undefined+nodes = undefined+lookup_node = undefined+type NodeMap a = Map.Map (Int,Int) (Int,Int,Int)+data SummaryNode = SummaryNode+moduleName = undefined+ms_mod = undefined+ms_hsc_src = undefined+
+ tests/examples/IfThenElse1.hs view
@@ -0,0 +1,7 @@+-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai+main = do+  cs <- if True+  then getLine+  else return "computer input"+  putStrLn cs+
+ tests/examples/IfThenElse2.hs view
@@ -0,0 +1,5 @@+-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai+main = if True+then print 12+else print 42+
+ tests/examples/IfThenElse3.hs view
@@ -0,0 +1,6 @@+-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai+main = do+  print 3+  if True then do+    print 5+    else print 7
+ tests/examples/ImplicitParams.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImplicitParams #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html++import Data.Char+++type LogFunction = String -> IO ()++type Present = String++queueNewChristmasPresents :: LogFunction -> [Present] -> IO ()+queueNewChristmasPresents logMessage presents = do+  mapM (logMessage . ("Queueing present for delivery: " ++)) presents+  return ()++queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO ()+queueNewChristmasPresents2 presents = do+  mapM (?logMessage . ("Queueing present for delivery: " ++)) presents+  return ()+++ex1 :: IO ()+ex1 =+  let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t)+  in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"]+++ex2 :: IO ()+ex2 = do+  -- Specifies its own logger+  ex1++  -- We can locally define a new logging function+  let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i+                                                     then c+                                                     else toUpper c)+                                           [0..]+                                           t)+  queueNewChristmasPresents2 ["Category Theory Books"]+
+ tests/examples/ImportsSemi.hs view
@@ -0,0 +1,6 @@+module ImportsSemi where+{+; ; ; ; ; ;+import Data.List+;;;+}
+ tests/examples/Infix.hs view
@@ -0,0 +1,8 @@++infix  3 &&&++(&&&) :: (Eq a) => [a] -> [a] -> [a]+(&&& ) [] [] =  []+xs  &&&   [] =  xs+(  &&&) [] ys =  ys+
+ tests/examples/LayoutIn1.hs view
@@ -0,0 +1,9 @@+module LayoutIn1 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'sq' to 'square'.++sumSquares x y= sq x + sq y where sq x= x^pow+  --There is a comment.+                                  pow=2
+ tests/examples/LayoutIn1.hs.expected view
@@ -0,0 +1,9 @@+module LayoutIn1 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'sq' to 'square'.++sumSquares x y= square x + square y where sq x= x^pow+          --There is a comment.+                                          pow=2
+ tests/examples/LayoutIn3.hs view
@@ -0,0 +1,13 @@+module LayoutIn3 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let x = 12 in (let y = 3+                           z = 2 in x * y * z * w) where   y = 2+                                                           --there is a comment.+                                                           w = x+                                                             where+                                                               x = let y = 5 in y + 3+
+ tests/examples/LayoutIn3.hs.expected view
@@ -0,0 +1,13 @@+module LayoutIn3 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let anotherX = 12 in (let y = 3+                                  z = 2 in anotherX * y * z * w) where   y = 2+                                                                         --there is a comment.+                                                                         w = x+                                                                           where+                                                                             x = let y = 5 in y + 3+
+ tests/examples/LayoutIn3a.hs view
@@ -0,0 +1,13 @@+module LayoutIn3a where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let x = 12 in (+                                    x            ) where   y = 2+                                                           --there is a comment.+                                                           w = x+                                                             where+                                                               x = let y = 5 in y + 3+
+ tests/examples/LayoutIn3a.hs.expected view
@@ -0,0 +1,13 @@+module LayoutIn3a where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let anotherX = 12 in (+                                    anotherX            ) where   y = 2+                                                                  --there is a comment.+                                                                  w = x+                                                                    where+                                                                      x = let y = 5 in y + 3+
+ tests/examples/LayoutIn3b.hs view
@@ -0,0 +1,12 @@+module LayoutIn3b where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let x = 12 in (             x            ) where   y = 2+                                                           --there is a comment.+                                                           w = x+                                                             where+                                                               x = let y = 5 in y + 3+
+ tests/examples/LayoutIn3b.hs.expected view
@@ -0,0 +1,12 @@+module LayoutIn3b where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'x' after 'let'  to 'anotherX'.++foo x = let anotherX = 12 in (             anotherX            ) where   y = 2+                                                                         --there is a comment.+                                                                         w = x+                                                                           where+                                                                             x = let y = 5 in y + 3+
+ tests/examples/LayoutIn4.hs view
@@ -0,0 +1,13 @@+module LayoutIn4 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'ioFun' to  'io'++main = ioFun "hello" where ioFun s= do  let  k = reverse s+ --There is a comment+                                        s <- getLine+                                        let  q = (k ++ s)+                                        putStr q+                                        putStr "foo"+
+ tests/examples/LayoutIn4.hs.expected view
@@ -0,0 +1,13 @@+module LayoutIn4 where++--Layout rule applies after 'where','let','do' and 'of'++--In this Example: rename 'ioFun' to  'io'++main = io "hello" where io s= do  let  k = reverse s+--There is a comment+                                  s <- getLine+                                  let  q = (k ++ s)+                                  putStr q+                                  putStr "foo"+
+ tests/examples/LayoutLet.hs view
@@ -0,0 +1,7 @@++foo x =+  let+    a = 1+    b = 2+  in x + a + b+
+ tests/examples/LayoutLet2.hs view
@@ -0,0 +1,9 @@+module LayoutLet2 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxx = let a = 1+              b = 2 in xxx + a + b+
+ tests/examples/LayoutLet2.hs.expected view
@@ -0,0 +1,9 @@+module LayoutLet2 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxxlonger = let a = 1+                    b = 2 in xxxlonger + a + b+
+ tests/examples/LayoutLet3.hs view
@@ -0,0 +1,10 @@+module LayoutLet3 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxx = let a = 1+              b = 2+          in xxx + a + b+
+ tests/examples/LayoutLet3.hs.expected view
@@ -0,0 +1,10 @@+module LayoutLet3 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxxlonger = let a = 1+                    b = 2+                in xxxlonger + a + b+
+ tests/examples/LayoutLet4.hs view
@@ -0,0 +1,11 @@+module LayoutLet4 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxx = let a = 1+              b = 2+          in xxx + a + b++bar = 3
+ tests/examples/LayoutLet4.hs.expected view
@@ -0,0 +1,11 @@+module LayoutLet4 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxxlonger = let a = 1+                    b = 2+                in xxxlonger + a + b++bar = 3
+ tests/examples/LayoutLet5.hs view
@@ -0,0 +1,11 @@+module LayoutLet5 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo xxx = let a = 1+              b = 2+          in xxx + a + b++bar = 3
+ tests/examples/LayoutLet5.hs.expected view
@@ -0,0 +1,11 @@+module LayoutLet5 where++-- Simple let expression, rename xxx to something longer or shorter+-- and the let/in layout should adjust accordingly+-- In this case the tokens for xxx + a + b should also shift out++foo x = let a = 1+            b = 2+        in x + a + b++bar = 3
+ tests/examples/LayoutWhere.hs view
@@ -0,0 +1,6 @@++foo x = r+  where+    a = 3+    b = 4+    r = a + a + b
+ tests/examples/LetExpr.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE PatternSynonyms #-}+{-# Language DeriveFoldable #-}+{-# LANGUAGE Safe #-}+{-# options_ghc -w #-}++-- | A simple let expression, to ensure the layout is detected+-- With some haddock in the top+{- And a normal+   multiline comment too -}+  module {- brah -}  LetExpr        ( foo -- foo does ..+                                    , bar -- bar does ..+                                    , Baz () -- baz does ..+                                 , Ba   ( ..),Ca(Cc,Cd)   ,+                                     bbb ,  aaa+                                  , module  Data.List+                                    , pattern  Bar+                                    )+    where++import Data.List+-- A comment in the middle+import {-# SOURCE #-} BootImport ( Foo(..) )+import {-# SoURCE  #-} safe   qualified  BootImport   as    BI+import qualified Data.Map as {- blah -}  Foo.Map++import Control.Monad  (   )+import Data.Word (Word8)+import Data.Tree hiding  (  drawTree   )++import qualified Data.Maybe as M hiding    ( maybe  , isJust  )+++-- comment+foo = let x = 1+          y = 2+      in x + y++bar = 3+bbb x+ | x == 1 = ()+ | otherwise = ()+++aaa [ ] _   = 0+aaa x  _unk = 1++aba () = 0++x `ccc` 1 = x + 1+x `ccc` y = x + y++x !@# y = x + y++data Baz = Baz1 | Baz2++data Ba = Ba | Bb++data Ca = Cc | Cd++pattern Foo a <- RealFoo a+pattern Bar a <- RealBar a++data Thing = RealFoo Thing | RealBar Int
+ tests/examples/LetExpr2.hs view
@@ -0,0 +1,4 @@+l z =+  let+    ll = 34+  in ll + z
+ tests/examples/LetExprSemi.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE PatternSynonyms #-}+{-# Language DeriveFoldable #-}+{-# LANGUAGE Safe #-}+{-# options_ghc -w #-}++-- | A simple let expression, to ensure the layout is detected+-- With some haddock in the top+{- And a normal+   multiline comment too -}+  module {- brah -}  LetExprSemi    ( foo -- foo does ..+                                    , bar -- bar does ..+                                    , Baz () -- baz does ..+                                 , Ba   ( ..),Ca(Cc,Cd)   ,+                                     bbb ,  aaa+                                  , module  Data.List+                                    , pattern  Bar+                                    )+    where+{+import Data.List+-- A comment in the middle+; import {-# SOURCE #-} BootImport ( Foo(..) ) ;+import {-# SOURCE  #-} safe   qualified  BootImport   as    BI+;;; import qualified Data.Map as {- blah -}  Foo.Map;++import Control.Monad  (   )  ;+import Data.Word (Word8);+import Data.Tree hiding  (  drawTree   ) ;++  ; import qualified Data.Maybe as M hiding    ( maybe  , isJust  )+;++-- comment+foo = let x = 1+          y = 2+      in x + y+;+bar = 3;+bbb x+ | x == 1 = ()+ | otherwise = ()++;+aaa [] _    = 0;+aaa x  _unk = 1+;+x `ccc` 1 = x + 1;+x `ccc` y = x + y+;+x !@# y = x + y+;+data Baz = Baz1 | Baz2+;+data Ba = Ba | Bb+;+data Ca = Cc | Cd+;+pattern Foo a <- RealFoo a ;+pattern Bar a <- RealBar a+;+data Thing = RealFoo Thing | RealBar Int+}++
+ tests/examples/LetStmt.hs view
@@ -0,0 +1,9 @@+-- A simple let statement, to ensure the layout is detected++module Layout.LetStmt where++foo = do+{- ffo -}let x = 1+             y = 2 -- baz+         x+y+
+ tests/examples/ListComprehensions.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ParallelListComp,+             TransformListComp,+             RecordWildCards #-}+--             MonadComprehensions,++-- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html++import GHC.Exts+import qualified Data.Map as M+import Data.Ord (comparing)+import Data.List (sortBy)++-- Let’s look at a simple, normal list comprehension to start:++regularListComp :: [Int]+regularListComp = [ x + y * z+                  | x <- [0..10]+                  , y <- [10..20]+                  , z <- [20..30]+                  ]++parallelListComp :: [Int]+parallelListComp = [ x + y * z+                   | x <- [0..10]+                   | y <- [10..20]+                   | z <- [20..30]+                   ]++-- fibs :: [Int]+-- fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++fibs :: [Int]+fibs = 0 : 1 : [ x + y+               | x <- fibs+               | y <- tail fibs+               ]++fiblikes :: [Int]+fiblikes = 0 : 1 : [ x + y + z+                   | x <- fibs+                   | y <- tail fibs+                   | z <- tail (tail fibs)+                   ]++-- TransformListComp+data Character = Character+  { firstName :: String+  , lastName :: String+  , birthYear :: Int+  } deriving (Show, Eq)++friends :: [Character]+friends = [ Character "Phoebe" "Buffay" 1963+          , Character "Chandler" "Bing" 1969+          , Character "Rachel" "Green" 1969+          , Character "Joey" "Tribbiani" 1967+          , Character "Monica" "Geller" 1964+          , Character "Ross" "Geller" 1966+          ]++oldest :: Int -> [Character] -> [String]+oldest k tbl = [ firstName ++ " " ++ lastName+               | Character{..} <- tbl+               , then sortWith by birthYear+               , then take k+               ]++groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]]+groupByLargest f = sortBy (comparing (negate . length)) . groupWith f++bestBirthYears :: [Character] -> [(Int, [String])]+bestBirthYears tbl = [ (the birthYear, firstName)+                     | Character{..} <- tbl+                     , then group by birthYear using groupByLargest+                     ]+
+ tests/examples/LocToName.hs view
@@ -0,0 +1,24 @@+module LocToName where++{-+++++++++-}++++++++sumSquares (x:xs) = x ^2 + sumSquares xs+    -- where sq x = x ^pow +    --       pow = 2++sumSquares [] = 0
+ tests/examples/LocToName.hs.expected view
@@ -0,0 +1,24 @@+module LocToName where++{-+++++++++-}++++++++LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs+    -- where sq x = x ^pow +    --       pow = 2++LocToName.newPoint [] = 0
+ tests/examples/Mixed.hs view
@@ -0,0 +1,48 @@++import Data.List  ()+import Data.List  hiding ()++infixl 1 `f`+-- infixr 2 `\\\`+infix  3 :==>+infix  4 `MkFoo`++data Foo = MkFoo Int | Float :==> Double++x `f` y = x++(\\\) :: (Eq a) => [a] -> [a] -> [a]+(\\\) xs ys =  xs++g x = x + if True then 1 else 2+h x = x + 1::Int++{-# SPECIALISe j :: Int -> Int #-}+j n = n + 1++test = let k x y = x+y in 1 `k` 2 `k` 3++data Rec = (:<-:) { a :: Int, b :: Float }++ng1 x y = negate y++instance (Num a, Num b) => Num (a,b)+  where+   negate (a,b) = (ng 'c' a, ng1 'c' b)   where  ng x y = negate y++++class Foo1 a where++class Foz a++x = 2 where+y = 3++instance Foo1 Int where++ff = ff where g = g where+type T = Int+++
+ tests/examples/MonadComprehensions.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ParallelListComp,+             TransformListComp,+             RecordWildCards #-}+{-# LANGUAGE MonadComprehensions #-}++-- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html++import GHC.Exts+import qualified Data.Map as M+import Data.Ord (comparing)+import Data.List (sortBy)+++-- Monad Comprehensions++sqrts :: M.Map Int Int+sqrts = M.fromList $ [ (x, sx)+                     | x  <- map (^2) [1..100]+                     | sx <- [1..100]+                     ]++sumIntSqrts :: Int -> Int -> Maybe Int+sumIntSqrts a b = [ x + y+                  | x <- M.lookup a sqrts+                  , y <- M.lookup b sqrts+                  ]++greet :: IO String+greet = [ name+        | name <- getLine+        , _ <- putStrLn $ unwords ["Hello, ", name, "!"]+        ]+
+ tests/examples/Move1.hs view
@@ -0,0 +1,53 @@+module Move1 where++data Located a = L Int a+type Name = String+hsBinds = undefined+divideDecls = undefined+definingDeclsNames = undefined+nub = undefined+definedPNs :: a -> [b]+definedPNs = undefined+logm = undefined+showGhc = undefined+pnsNeedRenaming = undefined+concatMap1 = undefined++-- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath+--                 -> Located Name+--                 -> RefactGhc [a]+liftToTopLevel' :: Int -> Located Name -> IO [a]+liftToTopLevel' modName pn@(L _ n) = do+  liftToMod+  return []+    where+          {-step1: divide the module's top level declaration list into three parts:+            'parent' is the top level declaration containing the lifted declaration,+            'before' and `after` are those declarations before and after 'parent'.+            step2: get the declarations to be lifted from parent, bind it to liftedDecls +            step3: remove the lifted declarations from parent and extra arguments may be introduce.+            step4. test whether there are any names need to be renamed.+          -}+       liftToMod :: IO ()+       liftToMod = do+                      -- renamed <- getRefactRenamed+                      let renamed = undefined+                      let declsr = hsBinds renamed+                      let (before,parent,after) = divideDecls declsr pn+                      -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ+++                      {- ++AZ++ : hsBinds does not return class or instance definitions+                      when (isClassDecl $ ghead "liftToMod" parent)+                            $ error "Sorry, the refactorer cannot lift a definition from a class declaration!"+                      when (isInstDecl $ ghead "liftToMod" parent)+                            $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"+                      -}+                      let liftedDecls = definingDeclsNames [n] parent True True+                          declaredPns = nub $ concatMap1 definedPNs liftedDecls++                      -- TODO: what about declarations between this+                      -- one and the top level that are used in this one?++                      logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))+                      -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns+                      -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns+                      return ()
+ tests/examples/MultiParamTypeClasses.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT)+import Data.Foldable (forM_)+import Data.IORef++class Store store m where+ new :: a -> m (store a)+ get :: store a -> m a+ put :: store a -> a -> m ()++type Present = String+storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present])+storePresents xs = do+  store <- new []+  forM_ xs $ \x -> do+    old <- get store+    put store (x : old)+  return store++instance Store IORef IO where+  new = newIORef+  get = readIORef+  put ioref a = modifyIORef ioref (const a)++-- ex ps = do+--   store <- storePresents ps+--   get (store :: IORef [Present])
+ tests/examples/NullaryTypeClasses.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE NullaryTypeClasses #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html++class Logger where+  logMessage :: String -> IO ()++type Present = String+queueNewChristmasPresents :: Logger => [Present] -> IO ()+queueNewChristmasPresents presents = do+  mapM (logMessage . ("Queueing present for delivery: " ++)) presents+  return ()++instance Logger where+  logMessage t = putStrLn ("[XMAS LOG]: " ++ t)+
+ tests/examples/OverloadedStrings.hs view
@@ -0,0 +1,15 @@+{-# Language OverloadedStrings #-}+-- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html++import Data.String++n :: Num a => a+n = 43++f  :: Fractional a => a+f = 03.1420++-- foo :: Text+foo :: Data.String.IsString a => a+foo = "hello\n there"+
+ tests/examples/PArr.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ParallelListComp #-}++module PArr where++blah xs ys = [ (x, y) | x <- xs | y <- ys ]++-- bar = [: 1, 2 .. 3 :]+++-- entry point for desugaring a parallel array comprehension++-- parr = [:e | qss:] = <<[:e | qss:]>> () [:():]++{-+ary = let arr1 = toP [1..10]+          arr2 = toP [1..10]+          f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :]+          in f !: 1+-}+++foo = 'a'+
+ tests/examples/ParensAroundContext.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE PartialTypeSignatures #-}+module ParensAroundContext where++f :: ((Eq a, _)) => a -> a -> Bool+f x y = x == y
+ tests/examples/PatBind.hs view
@@ -0,0 +1,34 @@+module   Layout.PatBind where++a,b :: Int+a = 1+b = 2++c :: Maybe (a -> b)+c = Nothing++f :: (Num a1, Num a) => a -> a1 -> ( a, a1 )+f x y = ( x+1, y-1 )++-- Chris done comment attachment problem+foo = x+  where -- do stuff+        doStuff = do stuff+x = 1+stuff = 4++ -- Pattern bind+tup :: (Int, Int)+h :: Int+t :: Int+tup@(h,t) = head $ zip [1..10] [3..ff]+  where+    ff :: Int+    ff = 15++blah = do {+ ; print "a"+ ; print "b"+ }++
+ tests/examples/PatSynBind.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html++import Foreign.C++{-++data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending++toBlendMode :: BlendMode -> CInt+toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE}+-- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND}++fromBlendMode :: CInt -> Maybe BlendMode+fromBlendMode 0 = Just NoBlending++-}++{-++pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt++setUpBlendMode :: CInt -> IO ()+setUpBlendMode AlphaBlending = do+  putStrLn "Enabling Alpha Blending"+  activateAlphaBlendingForAllTextures+  activateRenderAlphaBlending++-}++newtype BlendMode = MkBlendMode { unBlendMode :: CInt }++pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE}+pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND}++setUpBlendMode :: BlendMode -> IO ()+setUpBlendMode AlphaBlending = do+  putStrLn "Enabling Alpha Blending"+  activateAlphaBlendingForAllTextures+  activateRenderAlphaBlending++data Renderer++setRenderAlphaBlending :: Renderer -> IO ()+setRenderAlphaBlending r =+  sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending)++activateAlphaBlendingForAllTextures = return ()+activateRenderAlphaBlending = return ()++sdlSetRenderDrawBlendMode _ _ = return ()++-- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms++data Date = Date { month :: Int, day :: Int } deriving Show++-- Months+pattern January  day = Date { month = 1,  day = day }+pattern February day = Date { month = 2,  day = day }+pattern March    day = Date { month = 3,  day = day }+-- elided+pattern December day = Date { month = 12, day = day }++-- Holidays+pattern Christmas    = Date { month = 12, day = 25  }++describe :: Date -> String+describe (January 1)  = "First day of year"+describe (February n) = show n ++ "th of February"+describe Christmas    = "Presents!"+describe _            = "meh"++pattern Christmas2 = December 25++pattern BeforeChristmas <- December (compare 25 -> GT)+pattern Christmas3      <- December (compare 25 -> EQ)+pattern AfterChristmas  <- December (compare 25 -> LT)++react :: Date -> String+react BeforeChristmas = "Waiting :("+react Christmas       = "Presents!"+react AfterChristmas  = "Have to wait a whole year :("+react _               = "It's not even December..."++isItNow :: Int -> (Ordering, Int)+isItNow day = (compare 25 day, day)++pattern BeforeChristmas4 day <- December (isItNow -> (GT, day))+pattern Christmas4           <- December (isItNow -> (EQ, _))+pattern AfterChristmas4  day <- December (isItNow -> (LT, day))++days'tilChristmas :: Date -> Int+days'tilChristmas (BeforeChristmas4 n) = 25 - n+days'tilChristmas Christmas4           = 0+days'tilChristmas (AfterChristmas4 n)  = 365 + 25 - n
+ tests/examples/QuasiQuote.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE QuasiQuotes #-}+module QuasiQuote where++import T7918A++ex1 = [qq|e1|]+ex2 = [qq|e2|]+ex3 = [qq|e3|]+ex4 = [qq|e4|]++tx1 = undefined :: [qq|t1|]+tx2 = undefined :: [qq|t2|]+tx3 = undefined :: [qq|t3|]+tx4 = undefined :: [qq|t4|]++px1 [qq|p1|] = undefined+px2 [qq|p2|] = undefined+px3 [qq|p3|] = undefined+px4 [qq|p4|] = undefined
+ tests/examples/RankNTypes.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++-- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html++import System.Random+import Control.Monad.State+import Data.Char+++id' :: forall a. a -> a+id' x = x++f = print (id' (3 :: Integer),+           id' "blah")++-- rank 2 polymorphism+type IdFunc = forall a. a -> a++id'' :: IdFunc+id'' x = x++someInt :: IdFunc -> Integer+someInt id' = id' 3++-- rank 3 polymorphism+type SomeInt = IdFunc -> Integer++someOtherInt :: SomeInt -> Integer+someOtherInt someInt' =+    someInt' id + someInt' id++-- random numbers++data Player =+    Player {+      playerName :: String,+      playerPos  :: (Double, Double)+    }+    deriving (Eq, Ord, Show)+++{-+randomPlayer+    :: (MonadIO m, MonadState g m, RandomGen g)+    => m Player+-}++type GenAction m = forall a. (Random a) => m a++type GenActionR m = forall a. (Random a) => (a, a) -> m a++-- genRandom :: (RandomGen g) => GenAction (State g)+-- genRandom = state random++genRandomR :: (RandomGen g) => GenActionR (State g)+genRandomR range = state (randomR range)++genRandom :: (Random a, RandomGen g) => State g a+genRandom = state random+++randomPlayer :: (MonadIO m) => GenActionR m -> m Player+randomPlayer genR = do+    liftIO (putStrLn "Generating random player...")++    len <- genR (8, 12)+    name <- replicateM len (genR ('a', 'z'))+    x <- genR (-100, 100)+    y <- genR (-100, 100)++    liftIO (putStrLn "Done.")+    return (Player name (x, y))++main :: IO ()+main = randomPlayer randomRIO >>= print++-- scott encoding++data List a+    = Cons a (List a)+    | Nil++uncons :: (a -> List a -> r) -> r -> List a -> r+uncons co ni (Cons x xs) = co x xs+uncons co ni Nil         = ni++listNull :: List a -> Bool+listNull = uncons (\_ _ -> False) True++listMap :: (a -> b) -> List a -> List b+listMap f =+    uncons (\x xs -> Cons (f x) (listMap f xs))+           Nil++newtype ListS a =+    ListS {+      unconsS :: forall r. (a -> ListS a -> r) -> r -> r+    }++nilS :: ListS a+nilS = ListS (\co ni -> ni)++consS :: a -> ListS a -> ListS a+consS x xs = ListS (\co ni -> co x xs)++unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r+unconsS' co ni (ListS f) = f co ni++instance Functor ListS where+    fmap f =+        unconsS' (\x xs -> consS (f x) (fmap f xs))+                 nilS++-- Church Encoding+newtype ListC a =+    ListC {+      foldC :: forall r. (a -> r -> r) -> r -> r+    }++foldC' :: (a -> r -> r) -> r -> ListC a -> r+foldC' co ni (ListC f) = f co ni++instance Functor ListC where+    fmap f = foldC' (\x xs -> consC (f x) xs) nilC++consC = undefined+nilC = undefined++-- GADTs and continuation passing style+data Some :: * -> * where+    SomeInt  :: Int -> Some Int+    SomeChar :: Char -> Some Char+    Anything :: a -> Some a+++unSome :: Some a -> a+unSome (SomeInt x) = x + 3+unSome (SomeChar c) = toLower c+unSome (Anything x) = x+++newtype SomeC a =+    SomeC {+      runSomeC ::+          forall r.+          ((a ~ Int) => Int -> r) ->+          ((a ~ Char) => Char -> r) ->+          (a -> r) ->+          r+      }++-- dependent types++idk :: forall (a :: *). a -> a+idk x = x+
+ tests/examples/RdrNames.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TypeFamilies #-}+module RdrNames where++import Data.Monoid++-- ---------------------------------------------------------------------++--        |  'type' qcname            {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))+--                                            [mj AnnType $1,mj AnnVal $2] }++-- Tested in DataFamilies.hs++-- ---------------------------------------------------------------------++--        | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))+--                                       [mo $1,mj AnnVal $2,mc $3] }+ff = (RdrNames.:::) 0 1+++-- ---------------------------------------------------------------------++--        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))+--                                       [mo $1,mj AnnVal $2,mc $3] }+data FF = ( :::  ) Int Int++-- ---------------------------------------------------------------------++--        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))+--                                       [mj AnnBackquote $1,mj AnnVal $2+--                                       ,mj AnnBackquote $3] }+data GG = GG Int Int+gg = 0 `  GG ` 1++-- ---------------------------------------------------------------------++--        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))+--                                       [mj AnnBackquote $1,mj AnnVal $2+--                                       ,mj AnnBackquote $3] }+vv = "a" ` mappend  ` "b"++-- ---------------------------------------------------------------------++--        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))+--                                       [mj AnnBackquote $1,mj AnnVal $2+--                                       ,mj AnnBackquote $3] }+vvq = "a" `  Data.Monoid.mappend ` "b"++-- ---------------------------------------------------------------------++--        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)+--                                              [mo $1,mc $2] }+-- Tested in Vect.hs++-- ---------------------------------------------------------------------++--        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)+--                                              [mo $1,mc $2] }+-- Tested in Vect.hs++-- ---------------------------------------------------------------------++--        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple+--                                                        (snd $2 + 1)))+--                                       (mo $1:mc $3:(mcommas (fst $2))) }+ng :: (, , ,) Int Int Int Int+ng = undefined++-- ---------------------------------------------------------------------++--        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple+--                                                        (snd $2 + 1)))+--                                       (mo $1:mc $3:(mcommas (fst $2))) }+-- Tested in Unboxed.hs++-- ---------------------------------------------------------------------++--        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)+--                                       [mo $1,mj AnnRarrow $2,mc $3] }++ft :: (->) a b+ft = undefined++type family F a :: * -> * -> *+type instance F Int = (->)+type instance F Char = ( ,  )++-- ---------------------------------------------------------------------++--        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] }+lt :: [] a+lt = undefined++-- ---------------------------------------------------------------------++--        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }++-- GHC source indicates this constuctor is only available in PrelPArr+-- ltp :: [::] a+-- ltp = undefined++-- ---------------------------------------------------------------------++--        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)+--                                        [mo $1,mj AnnTildehsh $2,mc $3] }++-- primitive type?+-- Refl Int :: ~# * Int Int+-- Refl Maybe :: ~# (* -> *) Maybe Maybe+++-- ---------------------------------------------------------------------++--        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))+--                                               [mo $1,mj AnnVal $2,mc $3] }+-- TBD++-- ---------------------------------------------------------------------++--        | '(' '~' ')'                   {% ams (sLL $1 $> $ eqTyCon_RDR)+--                                               [mo $1,mj AnnTilde $2,mc $3] }++-- ---------------------------------------------------------------------++-- tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))+--                                        [mj AnnBackquote $1,mj AnnVal $2+--                                        ,mj AnnBackquote $3] }++-- ---------------------------------------------------------------------+++
+ tests/examples/RebindableSyntax.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-}++-- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html++import Prelude hiding ((>>), (>>=), return)+import Data.Monoid+import Control.Monad ((<=<))+import Data.Map as M++addNumbers = do+  80+  60+  10+  where (>>) = (+)+        return = return++(>>) = mappend+return = mempty++-- We can perform the same computation as above using the Sum wrapper:++someSum :: Sum Int+someSum = do+    Sum 80+    Sum 60+    Sum 10+    return++someProduct :: Product Int+someProduct = do+    Product 10+    Product 30++-- Why not try something non-numeric?++tummyMuscle :: String+tummyMuscle = do+    "a"+    "b"+++ff = let+  (>>)    = flip (.)+  return  = id++  arithmetic = do+      (+1)+      (*100)+      (/300)+      return++  -- Here, the input is numeric and all functions operate on a number.+  -- What if we want to take a list and output a string? No problem:++  check = do+      sum+      sqrt+      floor+      show+  in 4
+ tests/examples/RecordUpdate.hs view
@@ -0,0 +1,6 @@++data Foo = F { f1 :: Int, f2 :: String }++foo :: Int -> Foo -> Foo+foo v f = f { f1 = v }+
+ tests/examples/RecursiveDo.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE RecursiveDo #-}+-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html++import Control.Monad.Fix++data RoseTree a = RoseTree a [RoseTree a]+  deriving (Show)++exampleTree :: RoseTree Int+exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []]++pureMax :: Ord a => RoseTree a -> RoseTree (a, a)+pureMax tree =+  let (t, largest) = go largest tree+  in t+ where+  go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a)+  go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x)+  go biggest (RoseTree x xs) =+      let sub = map (go biggest) xs+          (xs', largests) = unzip sub+      in (RoseTree (x, biggest) xs', max x (maximum largests))++t = pureMax exampleTree++-- ---------------------------------------------------------------------++impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b))+impureMin f tree = do+  rec (t, largest) <- go largest tree+  return t+ where+  go smallest (RoseTree x []) = do+    b <- f x+    return (RoseTree (x, smallest) [], b)++  go smallest (RoseTree x xs) = do+    sub <- mapM (go smallest) xs+    b <- f x+    let (xs', bs) = unzip sub+    return (RoseTree (x, smallest) xs', min b (minimum bs))++budget :: String -> IO Int+budget "Ada"      = return 10 -- A struggling startup programmer+budget "Curry"    = return 50 -- A big-earner in finance+budget "Dijkstra" = return 20 -- Teaching is the real reward+budget "Howard"   = return 5  -- An frugile undergraduate!++inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" []+                            , RoseTree "Curry" [ RoseTree "Howard" []]+                            ]++ti = impureMin budget inviteTree+
+ tests/examples/Rename1.hs view
@@ -0,0 +1,6 @@+++foo x y =+   do c <- getChar+      return c+
+ tests/examples/Rename1.hs.expected view
@@ -0,0 +1,6 @@+++bar2 x y =+   do c <- getChar+      return c+
+ tests/examples/Roles.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE RoleAnnotations, PolyKinds #-}++module Roles where++data T1 a = K1 a+data T2 a = K2 a+data T3 (a :: k) = K3+data T4 (a :: * -> *) b = K4 (a b)++data T5 a = K5 a+data T6 a = K6+data T7 a b = K7 b++type role T1 nominal+type role T2 representational+type role T3 phantom+type role T4 nominal _+type role T5 _
+ tests/examples/Rules.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+module Rules where++import Data.Char++{-# RULES "map-loop" [ ~  ]  forall f . map' f = map' (id . f) #-}++{-# NOINLINE map' #-}+map' f [] = []+map' f (x:xs) = f x : map' f xs++main = print (map' toUpper "Hello, World")++-- Should warn+foo1 x = x+{-# RULES "foo1" [ 1] forall x. foo1 x = x #-}++-- Should warn+foo2 x = x+{-# INLINE foo2 #-}+{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-}++-- Should not warn+foo3 x = x+{-# NOINLINE foo3 #-}+{-# RULES "foo3" forall x. foo3 x = x #-}++{-# NOINLINE f #-}+f :: Int -> String+f x = "NOT FIRED"++{-# NOINLINE neg #-}+neg :: Int -> Int+neg = negate++{-# RULES+     "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED"+ #-}++
+ tests/examples/ScopedTypeVariables.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html++import qualified Data.Map as Map++insertMany ::  forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v+insertMany f vs m = foldr f1 m vs+  where+    f1 :: (k, v) -> Map.Map k v -> Map.Map k v+    f1 (k,v) m = Map.insertWith f k v m
+ tests/examples/Sigs.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE PatternSynonyms #-}++module Sigs where++-- TypeSig+f :: Num a => a -> a+f = undefined++pattern Single :: () => (Show a) => a -> [a]+pattern Single x = [x]++g :: (Show a) => [a] -> a+g (Single x) = x++-- Fixities++infixr  6 ++++infixr  7 ***,///++(+++) :: Int -> Int -> Int+a +++ b = a + 2*b++(***) :: Int -> Int -> Int+a *** b = a - 4*b++(///) :: Int -> Int -> Int+a /// b = 2*a - 3*b++-- Inline signatures++{-# Inline g #-}+{-# INLINE [~34] f #-}++-- Specialise signature++-- Multiple sigs+x,y,z :: Int+x = 0+y = 0+z = 0
+ tests/examples/Simple.hs view
@@ -0,0 +1,6 @@+-- A simple let statement, to ensure the layout is detected++-- module Layout.Simple where++x = 1+
+ tests/examples/Splice.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+          MultiParamTypeClasses, TypeSynonymInstances #-}++module Splice where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH++foo $( return $ VarP $ mkName "x" ) = x+bar $( [p| x |] ) = x++baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |]+++class Eq a => MyClass a+data Foo = Foo deriving Eq++instance MyClass Foo++data Bar = Bar+  deriving Eq++type Baz = Bar+instance MyClass Baz++data Quux a  = Quux a   deriving Eq+data Quux2 a = Quux2 a  deriving Eq+instance Eq a  => MyClass (Quux a)+instance Ord a => MyClass (Quux2 a)++class MyClass2 a b+instance MyClass2 Int Bool++$(return [])++main = do+    putStrLn $(do { info <- reify ''MyClass; lift (pprint info) })+    print $(isInstance ''Eq [ConT ''Foo] >>= lift)+    print $(isInstance ''MyClass [ConT ''Foo] >>= lift)+    print $ not $(isInstance ''Show [ConT ''Foo] >>= lift)+    print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one+    print $(isInstance ''MyClass [ConT ''Baz] >>= lift)+    print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one+    print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one+    print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift)+    print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift)+
+ tests/examples/StaticPointers.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import GHC.StaticPtr+import GHC.Word+import GHC.Generics+import Data.Data+import Data.Binary+import Data.ByteString++fact :: Int -> Int+fact 0 = 1+fact n = n * fact (n - 1)++main = do+  let sptr :: StaticPtr (Int -> Int)+      sptr = static fact+  print $ staticPtrInfo sptr+  print $ deRefStaticPtr sptr 10++-- ---------------------------------------------------------------------++type StaticKey1 = Fingerprint++-- Defined in GHC.Fingerprint.+data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+  deriving (Generic, Typeable)++staticKey :: StaticPtr a -> StaticKey1+staticKey = undefined++
+ tests/examples/Stmts.hs view
@@ -0,0 +1,22 @@+module Stmts where++-- Make sure we get all the semicolons in statements++foo :: IO ()+foo = do+  do { ;;;; a }+  a++bar :: IO ()+bar = do+  { ;+    a ;;+    b+  }++baz :: IO ()+baz = do { ;; s ; s ; ; s ;; }++a = undefined+b = undefined+s = undefined
+ tests/examples/Stream.hs view
@@ -0,0 +1,156 @@+module Stream (Stream, carry, addStream, rationalToStream,+                streamToFloat, addFiniteStream, negate', average) where++import Data.Ratio+++type Digit = Integer+type Stream = [Integer]++++-- Convert from a Rational fraction to its stream representation+rationalToStream :: Rational -> Stream+rationalToStream x+        |t<1            = 0:rationalToStream t+        |otherwise      = 1:rationalToStream (t-1)+        where t = 2*x+++++-- Convert from a stream to the Float value+streamToFloat :: Stream -> Float+streamToFloat x =  f x (1)++f :: Stream -> Integer -> Float+f [] n = 0+f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1)++++++-- Add two stream+addStream :: Stream -> Stream -> Stream+addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys))+                                where u = interim x1 x2 y1 y2+                                      c = carry x2 x3 y2 y3++++-- Compute carry, the C(i) value, given x(i) and y(i)+carry :: Digit -> Digit -> Digit -> Digit -> Digit+carry x1 x2 y1 y2+        |t>1                    =  1+        |t<(-1)                 = -1+        |t==1 && (minus1 x2 y2) =  0+        |t==1 && not (minus1 x2 y2) = 1+        |t==(-1) && (minus1 x2 y2) = -1+        |t==(-1) && not (minus1 x2 y2) = 0+        |t==0                           = 0+        where t = x1+y1++++-- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i)+interim :: Digit -> Digit -> Digit -> Digit -> Digit+interim x1 x2 y1 y2+                |t>1                    =  0+                |t<(-1)                 = 0+                |t==1 && (minus1 x2 y2) =  1+                |t==1 && not (minus1 x2 y2) = -1+                |t==(-1) && (minus1 x2 y2) = 1+                |t==(-1) && not (minus1 x2 y2) = -1+                |t==0                           = 0+                where t = x1+y1++++-- Check if at least one of 2 digits is -1+minus1 :: Digit -> Digit -> Bool+minus1 x y = (x==(-1))|| (y==(-1))+++++++-- Algin two stream so that they have the same length+align :: Stream -> Stream -> (Stream, Stream)+align xs ys+        |x>y            = (xs, (copy 0 (x-y)) ++ys)+        |otherwise      = ((copy 0 (y-x)) ++ xs, ys)+        where x = toInteger(length xs)+              y = toInteger(length ys)++++-- Generate a list of x+copy :: Integer -> Integer -> [Integer]+copy x n = [x| i<- [1..n]]++++++++-- Add two finite stream (to add the integral part)+addFiniteStream :: Stream -> Stream -> Stream+addFiniteStream xs ys = add' u v+                        where (u,v) = align xs ys++++-- Utility function for addFinitieStream+add' :: Stream -> Stream -> Stream+add' u v = normalise (f u v)+       where f [] [] = []+             f (x:xs) (y:ys) = (x+y):f xs ys+++-- Normalise the sum+normalise :: Stream -> Stream+normalise = foldr f [0]+            where f x (y:ys) = (u:v:ys)+                              where u = (x+y) `div` 2+                                    v = (x+y) `mod` 2+++-- Negate a stream+negate' :: Stream -> Stream+negate' = map (*(-1))++++-- Compute average of two stream+-- Using [-2,-1,0,1,2] to add, and then divide by 2+average :: Stream -> Stream -> Stream+average xs ys = div2 (add xs ys)+++-- Addition of two streams, using [-2,-1,0,1,2]+add :: Stream -> Stream -> Stream+add (x:xs) (y:ys) = (x+y):(add xs ys)+++-- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1]+div2 :: Stream -> Stream+div2 (2:xs)             = 1:div2 xs+div2 ((-2):xs)          = (-1):div2 xs+div2 (0:xs)             = 0:div2 xs+div2 (1:(-2):xs)        = div2 (0:0:xs)+div2 (1:(-1):xs)        = div2 (0:1:xs)+div2 (1:0:xs)           = div2 (0:2:xs)+div2 (1:1:xs)           = div2 (2:(-1):xs)+div2 (1:2:xs)           = div2 (2:0:xs)+div2 ((-1):(-2):xs)     = div2 ((-2):0:xs)+div2 ((-1):(-1):xs)     = div2 ((-2):1:xs)+div2 ((-1):0:xs)        = div2 (0:(-2):xs)+div2 ((-1):1:xs)        = div2 (0:(-1):xs)+div2 ((-1):2:xs)        = div2 (0:0:xs)++++test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3)))
+ tests/examples/StrictLet.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MagicHash #-}++{-+If the (unboxed, hence strict) "let thunk =" would survive to the CallArity+stage, it might yield wrong results (eta-expanding thunk and hence "cond" would+be called multiple times).++It does not actually happen (CallArity sees a "case"), so this test just+safe-guards against future changes here.+-}++import Debug.Trace+import GHC.Exts+import System.Environment++cond :: Int# -> Bool+cond x = trace ("cond called with " ++ show (I# x)) True+{-# NOINLINE cond #-}+++bar (I# x) =+    let go n = let x = thunk n+               in case n of+                    100# -> I# x+                    _    -> go (n +# 1#)+    in go x+  where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#)+++main = do+    args <- getArgs+    bar (length args) `seq` return ()
+ tests/examples/T2388.hs view
@@ -0,0 +1,14 @@+module T2388 where++import Data.Bits+import Data.Word+import Data.Int++test1 :: Word32 -> Char+test1 w | w .&. 0x80000000 /= 0 = 'a'+test1 _ = 'b'++-- this should use a testq instruction on x86_64+test2 :: Int64 -> Char+test2 w | w .&. (-3) /= 0 = 'a'+test2 _ = 'b'
+ tests/examples/T3132.hs view
@@ -0,0 +1,6 @@+module T3132 where++import Data.Array.Unboxed++step :: UArray Int Double -> [Double]+step y = [y!1 + y!0]
+ tests/examples/T7918A.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+module T7918A where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++qq = QuasiQuoter {+         quoteExp  = \str -> case str of+                                "e1" -> [| True |]+                                "e2" -> [| id True |]+                                "e3" -> [| True || False |]+                                "e4" -> [| False |]+       , quoteType = \str -> case str of+                                "t1" -> [t| Bool |]+                                "t2" -> [t| Maybe Bool |]+                                "t3" -> [t| Either Bool Int |]+                                "t4" -> [t| Int |]+       , quotePat  = let x = VarP (mkName "x")+                         y = VarP (mkName "y")+                     in \str -> case str of+                                  "p1" -> return $ x+                                  "p2" -> return $ ConP 'Just [x]+                                  "p3" -> return $ TupP [x, y]+                                  "p4" -> return $ y+       , quoteDec  = undefined+       }
+ tests/examples/TH.hs view
@@ -0,0 +1,71 @@+{-# Language TemplateHaskell #-}++-- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html++import Language.Haskell.TH++e1 :: IO Exp+e1 = runQ [| 1 + 2 |]++e2 :: Integer+e2 = $( return (InfixE (Just (LitE (IntegerL 1)))+                       (VarE (mkName "+"))+                       (Just (LitE (IntegerL 2)))+               )+      )++fibs :: [Integer]+fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++fibQ :: Int -> Q Exp+fibQ n = [| fibs !! n |]++-- e3 gives stage restriction, need to import this module to get it+-- e3 = $(fibQ 22)++e4 = $(runQ [| fibs !! $( [| 8 |]) |])++e5 :: IO Exp+e5 = runQ [| 1 + 2 |]++e6 :: IO [Dec]+e6 = runQ [d|x = 5|]++e7 :: IO Type+e7 = runQ [t|Int|]++e8 :: IO Pat+e8 = runQ [p|(x,y)|]++myExp :: Q Exp; myExp = runQ [| 1 + 2 |]++e9 = runQ(myExp) >>= putStrLn.pprint++-- ---------------------------------------------------------------------++isPrime :: (Integral a) => a -> Bool+isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1])++nextPrime :: (Integral a) => a -> a+nextPrime n | isPrime n = n | otherwise = nextPrime (n+1)++-- returns a list of all primes between n and m, using the nextPrime function+doPrime :: (Integral a) => a -> a -> [a]+doPrime n m+        | curr > m = []+        | otherwise = curr:doPrime (curr+1) m+        where curr = nextPrime n++-- and our Q expression+primeQ :: Int -> Int -> Q Exp+primeQ n m = [| doPrime n m |]++-- stage restriction on e10+-- e10 = $(primeQ 0 67)++-- ---------------------------------------------------------------------++e11 = $(stringE . show =<< reify ''Bool)++-- stage restriction e12+-- e12 = $(stringE . show =<< reify 'primeQ)
+ tests/examples/Trit.hs view
@@ -0,0 +1,112 @@+module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction',+                neg, addTrits, subTrits, shiftLeft, shiftRight, multiply+                ) where++import Stream+import Utilities+import Data.Ratio++type Mantissa = Stream+type Fraction = Stream+type Trit     = (Mantissa, Fraction)+++-- Convert from a Rational number to its Trit representation (Integral, Fraction)+rationalToTrit :: Rational -> Trit+rationalToTrit x+                |x<1            = ([0], rationalToStream x)+                |otherwise      = (u', rationalToStream v)+                where   u = n `div` d+                        u' = toBinary u+                        v = x - (toRational u)+                        n = numerator x+                        d = denominator x+++-- Get the integral part of Trit+getIntegral :: Trit -> Mantissa+getIntegral = fst++++-- Get the fraction part of Trit, with n digit of the stream+getFraction :: Int -> Trit -> Stream+getFraction n = take n. snd+++-- Get the fraction part of Trit+getFraction' :: Trit -> Stream+getFraction' = snd++++-- Negate a Trit+neg :: Trit -> Trit+neg (a, b) = (negate' a, negate' b)++++-- Add two Trits+addTrits :: Trit -> Trit -> Trit+addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys))+                                           where u' = addFiniteStream m1 m2+                                                 c = [carry x1 x2 y1 y2]+                                                 u = addFiniteStream u' c++++-- Substraction of 2 Trits+subTrits :: Trit -> Trit -> Trit+subTrits x y = addTrits x (neg y)++++-- Shift left = *2 opertaion with Trit+shiftLeft :: Trit -> Trit+shiftLeft (x, (y:ys)) = (x++ [y], ys)+++-- Shift right = /2 operation with Trit+shiftRight :: Trit -> Integer -> Trit+shiftRight (x, xs) 1 = (init x, (u:xs))+                    where u = last x+shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1)+                    where u = last x++++-- Multiply a Trit stream by 1,0 or -1, simply return the stream+mulOneDigit :: Integer -> Stream -> Stream+mulOneDigit x xs+              |x==1      = xs+              |x==0      = zero'+              |otherwise = negate' xs+              where zero' = (0:zero')+++++++-- Multiplication of two streams+multiply :: Stream -> Stream -> Stream+multiply (a0:a1:x) (b0:b1:y) = average p q+                               where p = average (a1*b0: (average (mulOneDigit b1 x)+                                                                 (mulOneDigit a1 y)))+                                                 (average (mulOneDigit b0 x)+                                                          (mulOneDigit a0 y))+                                     q = (a0*b0:a0*b1:a1*b1:(multiply x y))+++++start0 = take 30 (multiply (rationalToStream (1%2)) zo)++zo :: Stream+zo = 1:(-1):zero+     where zero = 0:zero++start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4))))+++
+ tests/examples/Tuple.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TupleSections #-}++baz = (1, "hello", 6.5,,) 'a' (Just ())+
+ tests/examples/TypeFamilies.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html++import Control.Concurrent.STM+import Control.Concurrent.MVar+import Data.Foldable (forM_)+import Data.IORef++class IOStore store where+  newIO :: a -> IO (store a)+  getIO :: store a -> IO a+  putIO :: store a -> a -> IO ()++instance IOStore MVar where+  newIO = newMVar+  getIO = readMVar+  putIO mvar a = modifyMVar_ mvar (return . const a)++instance IOStore IORef where+  newIO = newIORef+  getIO = readIORef+  putIO ioref a = modifyIORef ioref (const a)++type Present = String+storePresentsIO :: IOStore store => [Present] -> IO (store [Present])+storePresentsIO xs = do+  store <- newIO []+  forM_ xs $ \x -> do+    old <- getIO store+    putIO store (x : old)+  return store++-- Type family version++class Store store where+  type StoreMonad store :: * -> *+  new :: a -> (StoreMonad store) (store a)+  get :: store a -> (StoreMonad store) a+  put :: store a -> a -> (StoreMonad store) ()++instance Store IORef where+  type StoreMonad IORef = IO+  new = newIORef+  get = readIORef+  put ioref a = modifyIORef ioref (const a)++instance Store TVar where+  type StoreMonad TVar = STM+  new = newTVar+  get = readTVar+  put ioref a = modifyTVar ioref (const a)++storePresents :: (Store store, Monad (StoreMonad store))+              => [Present] -> (StoreMonad store) (store [Present])+storePresents xs = do+  store <- new []+  forM_ xs $ \x -> do+    old <- get store+    put store (x : old)+  return store+
+ tests/examples/TypeOperators.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++-- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html++import Data.String++data I a = I { unI :: a }+data Var a x = Var { unK :: a }++infixr 8 ++data ((f + g)) a = InL (f a) | InR (g a)+-- data (f + g) a = InL (f a) | InR (g a)++class sub :<: sup where+  inj :: sub a -> sup a++instance (sym :<: sym) where+  inj = id++instance (sym1 :<: (sym1 + sym2)) where inj = InL++instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where+  inj = InR . inj++instance (I :<: g, IsString s) => IsString ((f + g) s) where+  fromString = inj . I . fromString++var :: (Var a :<: f) => a -> f e+var = inj . Var++elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b+elim eval f =+  case f of+    InL (Var xs) -> inj (I (eval xs))+    InR g        -> g++--------------------------------------------------------------------------------++data UserVar = UserName++data ChristmasVar = ChristmasPresent++email :: [(Var UserVar + Var ChristmasVar + I) String]+email = [ "Dear "+        , var UserName+        , ", thank you for your recent email to Santa & Santa Inc."+        , "You have asked for a: "+        , var ChristmasPresent+        ]++main :: IO ()+main =+  do name <- getLine+     present <- getLine+     putStrLn (concatMap (unI .+                          (elim (\ChristmasPresent -> present) .+                           elim (\UserName -> name)))+                         email)++{-++*Main> main+Ollie+Lambda Necklace+Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace++-}
+ tests/examples/Unboxed.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE UnboxedTuples #-}+module Layout.Unboxed where++a,b :: Int+a = 1+b = 2++c :: Maybe (a -> b)+c = Nothing++f :: (Num a1, Num a) => a -> a1 -> (# a, a1 #)+f x y = (# x+1, y-1 #)++f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1+f1 x y = (# , #) x+1 y-1++g :: Num a => a -> a+g x = case f x x of { (# a, b #) -> a + b }+++ -- Pattern bind+tup :: (Int, Int)+h :: Int+t :: Int+tup@(h,t) = head $ zip [1..10] [3..ff]+  where+    ff :: Int+    ff = 15++
+ tests/examples/Utilities.hs view
@@ -0,0 +1,17 @@+module Utilities (toBinary, fl) where++import Stream+import Data.Ratio++-- Convert from an Integer to its signed-digit representation+toBinary :: Integer -> Stream+toBinary 0 = [0]+toBinary x = toBinary t ++ [x `mod` 2]+             where t = x `div` 2++++fl :: Stream -> Stream+fl (x:xs) = (f x):xs+          where f 0 = 1+                f 1 = 0
+ tests/examples/Utils2.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+module Utils2 where+++import Control.Applicative (Applicative(..))+import Control.Monad (when, liftM, ap)+import Control.Exception+import Data.Data+import Data.List+import Data.Maybe+import Data.Monoid++-- import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Types++import qualified Bag            as GHC+import qualified BasicTypes     as GHC+import qualified BooleanFormula as GHC+import qualified Class          as GHC+import qualified CoAxiom        as GHC+import qualified DynFlags       as GHC+import qualified FastString     as GHC+import qualified ForeignCall    as GHC+import qualified GHC            as GHC+import qualified GHC.Paths      as GHC+import qualified Lexer          as GHC+import qualified Name           as GHC+import qualified NameSet        as GHC+import qualified Outputable     as GHC+import qualified RdrName        as GHC+import qualified SrcLoc         as GHC+import qualified StringBuffer   as GHC+import qualified UniqSet        as GHC+import qualified Unique         as GHC+import qualified Var            as GHC++import qualified Data.Map as Map++-- ---------------------------------------------------------------------++instance AnnotateP GHC.RdrName where+  annotateP l n = do+    case rdrName2String n of+      "[]" -> do+        addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG+        addDeltaAnnotation GHC.AnnCloseS -- ']' BUG+      "()" -> do+        addDeltaAnnotation GHC.AnnOpenP -- '('+        addDeltaAnnotation GHC.AnnCloseP -- ')'+      "(##)" -> do+        addDeltaAnnotation GHC.AnnOpen -- '(#'+        addDeltaAnnotation GHC.AnnClose -- '#)'+      "[::]" -> do+        addDeltaAnnotation GHC.AnnOpen -- '[:'+        addDeltaAnnotation GHC.AnnClose -- ':]'+      _ ->  do+        addDeltaAnnotation GHC.AnnType+        addDeltaAnnotation GHC.AnnOpenP -- '('+        addDeltaAnnotationLs GHC.AnnBackquote 0+        addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)'+        cnt <- countAnnsAP GHC.AnnVal+        cntT <- countAnnsAP GHC.AnnCommaTuple+        cntR <- countAnnsAP GHC.AnnRarrow+        case cnt of+          0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal+          1 -> addDeltaAnnotation GHC.AnnVal+          x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x)+        addDeltaAnnotation GHC.AnnTildehsh+        addDeltaAnnotation GHC.AnnTilde+        addDeltaAnnotation GHC.AnnRarrow+        addDeltaAnnotationLs GHC.AnnBackquote 1+        addDeltaAnnotation GHC.AnnCloseP -- ')'++  -- temporary, for test+class (Typeable ast) => AnnotateP ast where+  annotateP :: GHC.SrcSpan -> ast -> IO ()++addDeltaAnnotation = undefined+addDeltaAnnotations = undefined+addDeltaAnnotationLs = undefined+addDeltaAnnotationExt = undefined+countAnnsAP = undefined+showGhc = undefined+rdrName2String = undefined+
+ tests/examples/Vect.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ParallelArrays #-}+{-# OPTIONS_GHC -fvectorise #-}+{-# LANGUAGE UnboxedTuples #-}++module Vect where++-- import Data.Array.Parallel+++{-# VECTORISe isFive = blah #-}+{-# NoVECTORISE isEq #-}++{-# VECTORISE SCALAR type Int  #-}+{-# VECTORISE        type Char #-}+{-# VECTORISE        type ( ) #-}+{-# VECTORISE        type (# #) #-}++{-# VECTORISE SCALAR type Integer = Int #-}+{-# VECTORISE        type Bool    = String  #-}++{-# Vectorise class Eq #-}++blah = 5++data MyBool = MyTrue | MyFalse++class Eq a => Cmp a where+  cmp :: a -> a -> Bool++-- FIXME:+-- instance Cmp Int where+--   cmp = (==)+-- isFive :: (Eq a, Num a) => a -> Bool+isFive :: Int -> Bool+isFive x = x == 5++isEq :: Eq a => a -> Bool+isEq x = x == x+++fiveEq :: Int -> Bool+fiveEq x = isFive x && isEq x++cmpArrs :: PArray Int -> PArray Int -> Bool+{-# NOINLINE cmpArrs #-}+cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w)++cmpArrs' :: [:Int:] -> [:Int:] -> Bool+cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:]++isFives :: PArray Int -> Bool+{-# NOINLINE isFives #-}+isFives xs = isFives' (fromPArrayP xs)++isFives' :: [:Int:] -> Bool+isFives' xs = andP (mapP isFive xs)++isEqs :: PArray Int -> Bool+{-# NOINLINE isEqs #-}+isEqs xs = isEqs' (fromPArrayP xs)++isEqs' :: [:Int:] -> Bool+isEqs' xs = undefined -- andP (mapP isEq xs)++-- fudge for compiler++fromPArrayP = undefined+andP = undefined+mapP = undefined+data PArray a = PArray a
+ tests/examples/ViewPatterns.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ViewPatterns #-}++-- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns+import Prelude hiding (length)++data JList a = Empty+             | Single a+             | Join (JList a) (JList a)++data JListView a = Nil+                 | Cons a (JList a)+++view :: JList a -> JListView a+view Empty = Nil+view (Single a) = Cons a Empty+view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y+view (Join (view -> Nil) y) = view y++length :: JList a -> Integer+length (view -> Nil) = 0+length (view -> Cons x xs) = 1 + length xs+
+ tests/examples/Warning.hs view
@@ -0,0 +1,16 @@++module Warning+{-# WARNINg ["This is a module warning",+             "multi-line"] #-}+  where++{-# Warning   foo ,  bar+         ["This is a multi-line",+          "deprecation message",+          "for foo"] #-}+foo :: Int+foo = 4++bar :: Char+bar = 'c'+
+ tests/examples/WhereIn4.hs view
@@ -0,0 +1,19 @@+module WhereIn4 where++--A definition can be demoted to the local 'where' binding of a friend declaration,+--if it is only used by this friend declaration.++--Demoting a definition narrows down the scope of the definition.+--In this example, demote the top level 'sq' to 'sumSquares'+--In this case (there is single matches), if possible,+--the parameters will be folded after demoting and type sigature will be removed.++sumSquares x y = sq p x + sq p y+         where p=2  {-There is a comment-}++sq::Int->Int->Int+sq pow z = z^pow  --there is a comment++anotherFun 0 y = sq y+     where  sq x = x^2+
+ tests/examples/WhereIn4.hs.expected view
@@ -0,0 +1,19 @@+module WhereIn4 where++--A definition can be demoted to the local 'where' binding of a friend declaration,+--if it is only used by this friend declaration.++--Demoting a definition narrows down the scope of the definition.+--In this example, demote the top level 'sq' to 'sumSquares'+--In this case (there is single matches), if possible,+--the parameters will be folded after demoting and type sigature will be removed.++sumSquares x y = sq p x + sq p y+         where p_2=2  {-There is a comment-}++sq::Int->Int->Int+sq pow z = z^pow  --there is a comment++anotherFun 0 y = sq y+     where  sq x = x^2+
+ tests/examples/Zipper.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Zipper+-- Copyright   :  (c) Michael D. Adams, 2010+-- License     :  BSD-style (see the LICENSE file)+--+-- ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types.+-- Michael D. Adams.  WGP '10: Proceedings of the 2010 ACM SIGPLAN+-- workshop on Generic programming, 2010.''+--+-- See <http://www.cs.indiana.edu/~adamsmd/papers/scrap_your_zippers/>+--+-----------------------------------------------------------------------------++{-# OPTIONS -Wall #-}+{-# LANGUAGE Rank2Types, GADTs #-}++module Zipper where++import Data.Generics+import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM)+import Data.Maybe (fromJust)++-- Core types++-- | A generic zipper with a root object of type @root@.+data Zipper root =+  forall hole. (Data hole) =>+    Zipper hole (Context hole root)++---- Internal types and functions+data Context hole root where+    CtxtNull :: Context a a+    CtxtCons ::+      forall hole root rights parent. (Data parent) =>+        Left (hole -> rights)+        -> Right rights parent+        -> Context parent root+        -> Context hole root++combine :: Left (hole -> rights)+         -> hole+         -> Right rights parent+         -> parent+combine lefts hole rights =+  fromRight ((fromLeft lefts) hole) rights++data Left expects+  = LeftUnit expects+  | forall b. (Data b) => LeftCons (Left (b -> expects)) b++toLeft :: (Data a) => a -> Left a+toLeft a = gfoldl LeftCons LeftUnit a++fromLeft :: Left r -> r+fromLeft (LeftUnit a)   = a+fromLeft (LeftCons f b) = fromLeft f b++data Right provides parent where+  RightNull :: Right parent parent+  RightCons ::+    (Data b) => b -> Right a t -> Right (b -> a) t++fromRight :: r -> Right r parent -> parent+fromRight f (RightNull)     = f+fromRight f (RightCons b r) = fromRight (f b) r++-- | Apply a generic monadic transformation to the hole+transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a)+transM f (Zipper hole ctxt) = do+  hole' <- f hole+  return (Zipper hole' ctxt)++-- Generic zipper traversals+---- Traversal helpers+-- | A movement operation such as 'left', 'right', 'up', or 'down'.+type Move a = Zipper a -> Maybe (Zipper a)++-- | Apply a generic query using the specified movement operation.+moveQ :: Move a -- ^ Move operation+      -> b -- ^ Default if can't move+      -> (Zipper a -> b) -- ^ Query if can move+      -> Zipper a -- ^ Zipper+      -> b+moveQ move b f z = case move z of+                     Nothing -> b+                     Just z' -> f z'++-- | Repeatedly apply a monadic 'Maybe' generic transformation at the+-- top-most, left-most position that the transformation returns+-- 'Just'.  Behaves like iteratively applying 'zsomewhere' but is+-- more efficient because it re-evaluates the transformation+-- at only the parents of the last successful application.+zreduce :: GenericM Maybe -> Zipper a -> Zipper a+zreduce f z =+  case transM f z of+    Nothing ->+      downQ (g z) (zreduce f . leftmost) z where+        g z' = rightQ (upQ z' g z') (zreduce f) z'+    Just x  -> zreduce f (reduceAncestors1 f x x)++reduceAncestors1 ::+  GenericM Maybe -> Zipper a -> Zipper a -> Zipper a+reduceAncestors1 f z def = upQ def g z where+  g z' = reduceAncestors1 f z' def' where+    def' = case transM f z' of+             Nothing -> def+             Just x  -> reduceAncestors1 f x x++------ Query+-- | Apply a generic query to the left sibling if one exists.+leftQ :: b -- ^ Value to return of no left sibling exists.+      -> (Zipper a -> b) -> Zipper a -> b+leftQ b f z = moveQ left b f z++-- | Apply a generic query to the right sibling if one exists.+rightQ :: b -- ^ Value to return if no right sibling exists.+       -> (Zipper a -> b) -> Zipper a -> b+rightQ b f z = moveQ right b f z++-- | Apply a generic query to the parent if it exists.+downQ :: b -- ^ Value to return if no children exist.+      -> (Zipper a -> b) -> Zipper a -> b+downQ b f z = moveQ down b f z++-- | Apply a generic query to the rightmost child if one exists.+upQ :: b -- ^ Value to return if parent does not exist.+    -> (Zipper a -> b) -> Zipper a -> b+upQ b f z = moveQ up b f z++---- Basic movement++-- | Move left.  Returns 'Nothing' iff already at leftmost sibling.+left  :: Zipper a -> Maybe (Zipper a)+left (Zipper _ CtxtNull) = Nothing+left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing+left (Zipper h (CtxtCons (LeftCons l h') r c)) =+  Just (Zipper h' (CtxtCons l (RightCons h r) c))++-- | Move right.  Returns 'Nothing' iff already at rightmost sibling.+right :: Zipper a -> Maybe (Zipper a)+right (Zipper _ CtxtNull) = Nothing+right (Zipper _ (CtxtCons _ RightNull _)) = Nothing+right (Zipper h (CtxtCons l (RightCons h' r) c)) =+  Just (Zipper h' (CtxtCons (LeftCons l h) r c))++-- | Move down.  Moves to rightmost immediate child.  Returns 'Nothing' iff at a leaf and thus no children exist.+down  :: Zipper a -> Maybe (Zipper a)+down (Zipper hole ctxt) =+  case toLeft hole of+    LeftUnit _ -> Nothing+    LeftCons l hole' ->+      Just (Zipper hole' (CtxtCons l RightNull ctxt))++-- | Move up.  Returns 'Nothing' iff already at root and thus no parent exists.+up    :: Zipper a -> Maybe (Zipper a)+up (Zipper _ CtxtNull) = Nothing+up (Zipper hole (CtxtCons l r ctxt)) =+  Just (Zipper (combine l hole r) ctxt)++------ Movement+-- | Move to the leftmost sibling.+leftmost :: Zipper a -> Zipper a+leftmost z = leftQ z leftmost z+