ghc-exactprint (empty) → 0.1.0.0
raw patch · 7 files changed
+5094/−0 lines, 7 filesdep +HUnitdep +basedep +containerssetup-changed
Dependencies added: HUnit, base, containers, directory, filepath, ghc, ghc-exactprint, ghc-paths, ghc-syb-utils, mtl, random, syb
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ghc-exactprint.cabal +64/−0
- src/Language/Haskell/GHC/ExactPrint.hs +2024/−0
- src/Language/Haskell/GHC/ExactPrint/Types.hs +154/−0
- src/Language/Haskell/GHC/ExactPrint/Utils.hs +2461/−0
- tests/Test.hs +359/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Alan Zimmerman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alan Zimmerman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-exactprint.cabal view
@@ -0,0 +1,64 @@+-- Initial ghc-exactprint.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: ghc-exactprint+version: 0.1.0.0+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+ be compiled by GHC+ .+ * any currently excludes anything using CPP or lhs.+ .+ The dependency footprint is deliberately kept small so that+ it can easily be tested against GHC HEAD++license: BSD3+license-file: LICENSE+author: Alan Zimmerman+maintainer: alan.zimm@gmail.com+-- copyright:+category: Development+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Language.Haskell.GHC.ExactPrint+ , Language.Haskell.GHC.ExactPrint.Types+ , Language.Haskell.GHC.ExactPrint.Utils+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.7 && <4.9+ , containers+ , ghc+ , ghc-paths+ , syb+ hs-source-dirs: src+ default-language: Haskell2010+++Test-Suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Test.hs+ GHC-Options: -threaded+ Default-language: Haskell2010+ Build-depends: base < 5,+ mtl,+ containers,+ ghc-exactprint,+ filepath,+ directory,+ syb,+ ghc-syb-utils,+ ghc,+ ghc-paths,+ HUnit,+ random++source-repository head+ type: git+ location: https://github.com/alanz/ghc-exactprint.git++
+ src/Language/Haskell/GHC/ExactPrint.hs view
@@ -0,0 +1,2024 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.GHC.ExactPrint+-- Based on+-- --------------------------------------------------------------------------+-- Module : Language.Haskell.Exts.Annotated.ExactPrint+-- Copyright : (c) Niklas Broberg 2009+-- License : BSD-style (see the file LICENSE.txt)+--+-- Maintainer : Niklas Broberg, d00nibro@chalmers.se+-- Stability : stable+-- Portability : portable+--+-- Exact-printer for Haskell abstract syntax. The input is a (semi-concrete)+-- abstract syntax tree, annotated with exact source information to enable+-- printing the tree exactly as it was parsed.+--+-----------------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint+ ( annotateAST+ , Anns+ , exactPrintAnnotated+ , exactPrintAnnotation++ , exactPrint+ , ExactP++ ) where++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++import Control.Monad (when, liftM, ap)+import Control.Exception+import Data.Data+import Data.List+-- import Data.List.Utils -- TODO: Reinstate when available++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++newtype EP x = EP (Pos -> [(Int,DeltaPos)] -> [GHC.SrcSpan] -> [Comment] -> Extra -> Anns+ -> (x, Pos, [(Int,DeltaPos)], [GHC.SrcSpan], [Comment], Extra, Anns, ShowS))++data Extra = E { eFunId :: (Bool,String) -- (isSymbol,name)+ , eFunIsInfix :: Bool+ }++initExtra :: Extra+initExtra = E (False,"") False++instance Functor EP where+ fmap = liftM++instance Applicative EP where+ pure = return+ (<*>) = ap++instance Monad EP where+ return x = EP $ \l dp s cs st an -> (x, l, dp, s, cs, st, an, id)++ EP m >>= k = EP $ \l0 ss0 dp0 c0 st0 an0 -> let+ (a, l1, ss1, dp1, c1, st1, an1, s1) = m l0 ss0 dp0 c0 st0 an0+ EP f = k a+ (b, l2, ss2, dp2, c2, st2, an2, s2) = f l1 ss1 dp1 c1 st1 an1+ in (b, l2, ss2, dp2, c2, st2, an2, s1 . s2)++runEP :: EP () -> GHC.SrcSpan -> [Comment] -> Anns -> String+runEP (EP f) ss cs ans = let (_,_,_,_,_,_,_,s) = f (1,1) [(0,DP (0,0))] [ss] cs initExtra ans in s ""++getPos :: EP Pos+getPos = EP (\l dp s cs st an -> (l,l,dp,s,cs,st,an,id))++setPos :: Pos -> EP ()+setPos l = EP (\_ dp s cs st an -> ((),l,dp,s,cs,st,an,id))++-- ---------------------------------------------------------------------++-- Get the current column offset+getOffset :: EP Int+getOffset = EP (\l dps s cs st an -> (fst $ ghead "getOffset" dps,l,dps,s,cs,st,an,id))++pushOffset :: DeltaPos -> EP ()+pushOffset dp@(DP (f,dc)) = EP (\l dps s cs st an ->+ let+ (co,_) = ghead "pushOffset" dps+ -- co' = if f == 1 then dc+ -- else dc + co+ co' = dc + co+ in ((),l,(co',dp):dps,s,cs,st,an,id)+ `debug` ("pushOffset:co'=" ++ show co')+ )++popOffset :: EP ()+popOffset = EP (\l (_o:dp) s cs st an -> ((),l,dp,s,cs,st,an,id)+ `debug` ("popOffset:co=" ++ show (fst _o))+ )++-- ---------------------------------------------------------------------++pushSrcSpan :: GHC.SrcSpan -> EP ()+pushSrcSpan ss = EP (\l dp sss cs st an -> ((),l,dp,(ss:sss),cs,st,an,id))++popSrcSpan :: EP ()+popSrcSpan = EP (\l dp (_:sss) cs st an -> ((),l,dp,sss,cs,st,an,id))+++getAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)+getAnnotation a = EP (\l dp s cs st an -> (getAnnotationEP (anEP an) a+ ,l,dp,s,cs,st,an,id))++getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)+getAndRemoveAnnotation a = EP (\l dp s cs st (ane,anf) ->+ let+ (r,ane') = getAndRemoveAnnotationEP ane a+ in+ (r, l,dp,s,cs,st,(ane',anf),id))+++-- |destructive get, hence use an annotation once only+getAnnFinal :: KeywordId -> EP [DeltaPos]+getAnnFinal kw = EP (\l dp (s:ss) cs st (ane,anf) ->+ let+ (r,anf') = case Map.lookup (s,kw) anf of+ Nothing -> ([],anf)+ Just ds -> ([d],f')+ where+ (d,f') = case reverse ds of+ [h] -> (h,Map.delete (s,kw) anf)+ (h:t) -> (h,Map.insert (s,kw) (reverse t) anf)+ in (r ,l,dp,(s:ss),cs,st,(ane,anf'),id))++-- |non-destructive get, hence use an annotation once only+peekAnnFinal :: KeywordId -> EP [DeltaPos]+peekAnnFinal kw = EP (\l dp (s:ss) cs st (ane,anf) ->+ let+ r = case Map.lookup (s,kw) anf of+ Nothing -> []+ Just ds -> ds+ in (r ,l,dp,(s:ss),cs,st,(ane,anf),id))++getFunId :: EP (Bool,String)+getFunId = EP (\l dp s cs st an -> (eFunId st,l,dp,s,cs,st,an,id))++setFunId :: (Bool,String) -> EP ()+setFunId st = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunId = st},an,id))++getFunIsInfix :: EP Bool+getFunIsInfix = EP (\l dp s cs e an -> (eFunIsInfix e,l,dp,s,cs,e,an,id))++setFunIsInfix :: Bool -> EP ()+setFunIsInfix b = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunIsInfix = b},an,id))++-- ---------------------------------------------------------------------++printString :: String -> EP ()+printString str = EP (\(l,c) dp s cs st an ->+ ((), (l,c+length str), dp, s, cs, st, an, showString str))++getComment :: EP (Maybe Comment)+getComment = EP $ \l dp s cs st an ->+ let x = case cs of+ c:_ -> Just c+ _ -> Nothing+ in (x, l, dp, s, cs, st, an, id)++dropComment :: EP ()+dropComment = EP $ \l dp s cs st an ->+ let cs' = case cs of+ (_:csl) -> csl+ _ -> cs+ in ((), l, dp, s, cs', st, an, id)++mergeComments :: [DComment] -> EP ()+mergeComments dcs = EP $ \l dps s cs st an ->+ let ll = ss2pos $ head s+ (co,_) = ghead "mergeComments" dps+ acs = map (undeltaComment ll co) dcs+ cs' = merge acs cs+ in ((), l, dps, s, cs', st, an, id) `debug` ("mergeComments:(l,acs,dcs)=" ++ show (l,acs,dcs))++newLine :: EP ()+newLine = do+ (l,_) <- getPos+ printString "\n"+ setPos (l+1,1)++padUntil :: Pos -> EP ()+padUntil (l,c) = do+ (l1,c1) <- getPos+ case {- trace (show ((l,c), (l1,c1))) -} () of+ _ {-()-} | l1 >= l && c1 <= c -> printString $ replicate (c - c1) ' '+ | l1 < l -> newLine >> padUntil (l,c)+ | otherwise -> return ()++mPrintComments :: Pos -> EP ()+mPrintComments p = do+ mc <- getComment+ case mc of+ Nothing -> return ()+ Just (Comment multi (s,e) str) ->+ (+ when (s < p) $ do+ dropComment+ padUntil s+ printComment multi str+ setPos e+ mPrintComments p+ ) -- `debug` ("mPrintComments:(s,p):" ++ show (s,p))++printComment :: Bool -> String -> EP ()+printComment b str+ | b = printString str+ | otherwise = printString str++-- Single point of delta application+printWhitespace :: Pos -> EP ()+printWhitespace (r,c) = do+ let (dr,dc) = (0,0)+ let p = (r + dr, c + dc)+ mPrintComments p >> padUntil p++printStringAt :: Pos -> String -> EP ()+printStringAt p str = printWhitespace p >> printString str++-- ---------------------------------------------------------------------++printStringAtLsDelta :: [DeltaPos] -> String -> EP ()+printStringAtLsDelta mc s =+ case reverse mc of+ (cl:_) -> do+ p <- getPos+ colOffset <- getOffset+ -- if isGoodDelta cl+ if isGoodDeltaWithOffset cl colOffset+ then printStringAt (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))++-- ---------------------------------------------------------------------++printStringAtMaybeAnn :: KeywordId -> String -> EP ()+printStringAtMaybeAnn an str = do+ ma <- getAnnFinal an+ printStringAtLsDelta ma str+ `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str))++printStringAtMaybeAnnAll :: KeywordId -> String -> EP ()+printStringAtMaybeAnnAll an str = go+ where+ go = do+ ma <- getAnnFinal an+ case ma of+ [] -> return ()+ [d] -> printStringAtLsDelta [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 -> [Comment] -> String+exactPrint ast@(GHC.L l _) cs = runEP (exactPC ast) l cs (Map.empty,Map.empty)+++exactPrintAnnotated ::+ GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> String+exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (loadInitialComments >> exactPC ast) l [] an+ where+ an = annotateLHsModule ast ghcAnns++exactPrintAnnotation :: ExactP ast =>+ GHC.Located ast -> [Comment] -> Anns -> String+exactPrintAnnotation ast@(GHC.L l _) cs an = runEP (loadInitialComments >> exactPC ast) l cs 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++loadInitialComments :: EP ()+loadInitialComments = do+ -- return () `debug` ("loadInitialComments entered")+ Just (Ann cs _) <- getAnnotation (GHC.L GHC.noSrcSpan ())+ mergeComments cs -- `debug` ("loadInitialComments cs=" ++ show cs)+ -- return () `debug` ("loadInitialComments exited")+ return ()++-- |First move to the given location, then call exactP+exactPC :: (Data ast,ExactP ast) => GHC.Located ast -> EP ()+exactPC a@(GHC.L l ast) =+ do pushSrcSpan l `debug` ("exactPC entered for:" ++ showGhc l)+ -- ma <- getAnnotation a+ ma <- getAndRemoveAnnotation a+ offset <- case ma of+ Nothing -> return (DP (0,0))+ `debug` ("exactPC:no annotation for " ++ show (ss2span l,typeOf ast))+ Just (Ann lcs dp) -> do+ mergeComments lcs `debug` ("exactPC:(l,lcs,dp):" ++ show (showGhc l,lcs,dp))+ return dp++ pushOffset offset+ do+ exactP ast+ printStringAtMaybeAnn (G GHC.AnnComma) ","+ printStringAtMaybeAnnAll AnnSemiSep ";"+ popOffset++ popSrcSpan+++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+ setFunId (isSymbolRdrName n,rdrName2String n)+ setFunIsInfix 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++ 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+ 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) "{"+ exactP 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+ printStringAtMaybeAnn (G GHC.AnnLet) "let"+ printStringAtMaybeAnn (G GHC.AnnOpenC) "{"+ printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"+ exactP lb+ printStringAtMaybeAnn (G GHC.AnnCloseC) "}"+ printStringAtMaybeAnn (G GHC.AnnIn) "in"+ exactPC e++ 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+ mapM_ exactPC 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 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+ 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+ printStringAtMaybeAnn (G GHC.AnnCloseC) "}"++ exactP (GHC.HsCmdCast {}) = error $ "exactP.HsCmdCast: only valid after type checker"++-- ---------------------------------------------------------------------++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 _ _ _)+ = mapM_ exactPC matches++-- ---------------------------------------------------------------------++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) "#-}"++-- ---------------------------------------------------------------------++
+ src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId+module Language.Haskell.GHC.ExactPrint.Types+ (+ Comment(..)+ , DComment(..)+ , Pos+ , Span+ , PosToken+ , DeltaPos(..)+ , Annotation(..)+ , annNone+ , Anns,anEP,anF+ , AnnsEP+ , AnnsFinal+ , KeywordId(..)+ , AnnConName(..)+ , annGetConstr+ , unConName++ , ResTyGADTHook(..)++ , AnnKey+ , AnnKeyF+ , mkAnnKeyEP+ , getAnnotationEP+ , getAndRemoveAnnotationEP++ ) where++import Data.Data++import qualified GHC as GHC+import qualified Outputable as GHC++import qualified Data.Map as Map++-- ---------------------------------------------------------------------++-- | A Haskell comment. The 'Bool' is 'True' if the comment is multi-line, i.e. @{- -}@.+data Comment = Comment Bool Span String+ deriving (Eq,Show,Typeable,Data)++-- |Delta version of the comment. The initial Int is the column offset+-- that was force when the DeltaPos values were calculated. If this is+-- different when it is output, they deltas must be updated.+data DComment = DComment Int Bool (DeltaPos,DeltaPos) String+ deriving (Eq,Show,Typeable,Data)++instance Ord Comment where+ compare (Comment _ p1 _) (Comment _ p2 _) = compare p1 p2++type PosToken = (GHC.Located GHC.Token, String)++type Pos = (Int,Int)+type Span = (Pos,Pos)++newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)++annNone :: Annotation+annNone = Ann [] (DP (0,0))++data Annotation = Ann+ { ann_comments :: ![DComment]+ , ann_delta :: !DeltaPos -- Do we need this? Yes indeed.+ } deriving (Show,Typeable)+++instance Show GHC.RdrName where+ show n = "(a RdrName)"++-- first field carries the comments, second the offsets+type Anns = (AnnsEP,AnnsFinal)+anEP :: Anns -> AnnsEP+anEP (e,_) = e+anF :: Anns -> AnnsFinal+anF (_,f) = f++-- Holds the name of a constructor+data AnnConName = CN String+ deriving (Eq,Show,Ord)++annGetConstr :: (Data a) => a -> AnnConName+annGetConstr a = CN (show $ toConstr a)++unConName :: AnnConName -> String+unConName (CN s) = s++++-- | For every @Located a@, use the @SrcSpan@ and constructor name of+-- a as the key, to store the standard annotation.+-- These are used to maintain context in the AP and EP monads+type AnnsEP = Map.Map (GHC.SrcSpan,AnnConName) Annotation+type AnnKey = (GHC.SrcSpan,AnnConName)++-- | The offset values used for actually outputing the source. For a+-- given @'SrcSpan'@, in a context managed by the AP or EP monads,+-- store a list of offsets for a particular KeywordId. Mostly there+-- will only be one, but in certain circumstances they are multiple,+-- e.g. semi colons as separators, which can be repeated.+type AnnsFinal = Map.Map (GHC.SrcSpan,KeywordId) [DeltaPos]+type AnnKeyF = (GHC.SrcSpan,KeywordId)++-- |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.+data KeywordId = G GHC.AnnKeywordId+ | AnnSemiSep+ deriving (Eq,Show,Ord)++-- ---------------------------------------------------------------------++instance GHC.Outputable KeywordId where+ ppr k = GHC.text (show k)++instance GHC.Outputable (AnnConName) where+ ppr tr = GHC.text (show tr)++instance GHC.Outputable Annotation where+ ppr a = GHC.text (show a)++instance GHC.Outputable DeltaPos where+ ppr a = GHC.text (show a)++-- ---------------------------------------------------------------------++-- ResTyGADT has a SrcSpan for the original sigtype, we need to create+-- a type for exactPC and annotatePC+data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]+ deriving (Typeable)+deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)+deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)++instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where+ ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs++-- ---------------------------------------------------------------------++mkAnnKeyEP :: (Data a) => GHC.Located a -> AnnKey+mkAnnKeyEP (GHC.L l a) = (l,annGetConstr a)++getAnnotationEP :: (Data a) => AnnsEP -> GHC.Located a -> Maybe Annotation+getAnnotationEP anns (GHC.L ss a) = Map.lookup (ss, annGetConstr a) anns++getAndRemoveAnnotationEP :: (Data a)+ => AnnsEP -> GHC.Located a -> (Maybe Annotation,AnnsEP)+getAndRemoveAnnotationEP anns (GHC.L ss a)+ = case Map.lookup (ss, annGetConstr a) anns of+ Nothing -> (Nothing,anns)+ Just ann -> (Just ann,Map.delete (ss, annGetConstr a) anns)
+ src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -0,0 +1,2461 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId+module Language.Haskell.GHC.ExactPrint.Utils+ (+ annotateLHsModule++ , organiseAnns+ , OrganisedAnns++ -- , ghcIsComment+ , ghcIsMultiLine++ , srcSpanStartLine+ , srcSpanEndLine+ , srcSpanStartColumn+ , srcSpanEndColumn++ , ss2span+ , ss2pos+ , ss2posEnd+ , undelta+ , undeltaComment+ , isGoodDelta+ , rdrName2String+ , isSymbolRdrName++ , isListComp++ , showGhc+ , showAnnData++ , merge++ -- * For tests+ , debug++ , runAP+ , AP(..)+ , getSrcSpanAP, pushSrcSpanAP, popSrcSpanAP+ , getAnnotationAP+ , addAnnotationsAP++ , ghead+ , glast+ , gtail+ , gfromJust++ ) where++import Control.Monad ( liftM, ap)+import Control.Exception+import Data.Data+import Data.Generics+import Data.List+import Data.Monoid++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++-- ---------------------------------------------------------------------++-- | 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++{- -}+newtype AP x = AP ([(GHC.SrcSpan,AnnConName)] -> GHC.SrcSpan -> Extra -> GHC.ApiAnns+ -> (x, [(GHC.SrcSpan,AnnConName)], GHC.SrcSpan, Extra, GHC.ApiAnns,+ ([(AnnKey,Annotation)],[(AnnKeyF,[DeltaPos])])+ ))++-- TODO: AZ: Is this still needed?+type Extra = Bool -- isInfix for a FunBind++instance Functor AP where+ fmap = liftM++instance Applicative AP where+ pure = return+ (<*>) = ap++instance Monad AP where+ return x = AP $ \l pe e ga -> (x, l, pe, e, ga, mempty)++ AP m >>= k = AP $ \l0 p0 e0 ga0 -> let+ (a, l1, p1, e1, ga1, s1) = m l0 p0 e0 ga0+ AP f = k a+ (b, l2, p2, e2, ga2, s2) = f l1 p1 e1 ga1+ in (b, l2, p2, e2, ga2, s1 <> s2)+++runAP :: AP () -> GHC.ApiAnns -> Anns+runAP (AP f) ga+ = let (_,_,_,_,_,(se,sa)) = f [] GHC.noSrcSpan False ga+ in (Map.fromListWith combineAnns se,Map.fromListWith (++) sa)+ -- `debug` ("runAP:se=" ++ show se)++combineAnns :: Annotation -> Annotation -> Annotation+combineAnns (Ann cs1 dp1) (Ann cs2 _) = Ann (cs1 ++ cs2) dp1++-- -------------------------------------++-- |Note: assumes the SrcSpan stack is nonempty+getSrcSpanAP :: AP GHC.SrcSpan+-- getSrcSpanAP = AP (\l pe e ga -> (fst $ ghead "getSrcSpanAP" l,l,pe,e,ga,mempty))+getSrcSpanAP = AP (\l@((ss,_):_) pe e ga -> (ss,l,pe,e,ga,mempty))++getPriorSrcSpanAP :: AP GHC.SrcSpan+getPriorSrcSpanAP = AP (\l@(_:(ss,_):_) pe e ga -> (ss,l,pe,e,ga,mempty))++pushSrcSpanAP :: Data a => (GHC.Located a) -> AP ()+pushSrcSpanAP (GHC.L l a) = AP (\ls pe e ga -> ((),(l,annGetConstr a):ls,pe,e,ga,mempty))++popSrcSpanAP :: AP ()+popSrcSpanAP = AP (\(_:ls) pe e ga -> ((),ls,pe,e,ga,mempty))++-- ---------------------------------------------------------------------++startGroupingOffsets :: AP ()+startGroupingOffsets = do+ return ()++stopGroupingOffsets :: AP ()+stopGroupingOffsets = do+ return ()++amendDeltaForGrouping :: DeltaPos -> AP DeltaPos+amendDeltaForGrouping p = do+ return p++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)) =+ let+ c' = c - colOffset+ in (DP (l,c'))++-- ---------------------------------------------------------------------++-- | Get the current column offset+getCurrentColOffset :: AP Int+getCurrentColOffset = do+ ss <- getSrcSpanAP+ return (srcSpanStartColumn ss) -- AZ: - 1?++-- |Get the difference between the current and the previous+-- colOffsets, if they are on the same line+getCurrentDP :: AP DeltaPos+getCurrentDP = do+ ss <- getSrcSpanAP+ ps <- getPriorSrcSpanAP+ if srcSpanStartLine ss == srcSpanStartLine ps+ then return (DP (0,srcSpanStartColumn ss - srcSpanStartColumn ps))+ -- else return (DP (1,srcSpanStartColumn ss))+ else return (DP (0,srcSpanStartColumn ss - srcSpanStartColumn ps))+++-- ---------------------------------------------------------------------++-- |Note: assumes the prior end SrcSpan stack is nonempty+getPriorEnd :: AP GHC.SrcSpan+getPriorEnd = AP (\l pe e ga -> (pe,l,pe,e,ga,mempty))++setPriorEnd :: GHC.SrcSpan -> AP ()+setPriorEnd pe = AP (\ls _ e ga -> ((),ls,pe,e,ga,mempty))++-- -------------------------------------++getAnnotationAP :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP [GHC.SrcSpan]+getAnnotationAP sp an = AP (\l pe e ga+ -> (GHC.getAnnotation ga sp an, l,pe,e,ga,mempty))+++getAndRemoveAnnotationAP :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP [GHC.SrcSpan]+getAndRemoveAnnotationAP sp an = AP (\l pe e ga ->+ let+ (r,ga') = GHC.getAndRemoveAnnotation ga sp an+ in (r, l,pe,e,ga',mempty))++-- -------------------------------------+-- |Retrieve the comments allocated to the current 'SrcSpan', and+-- remove them from the annotations+getAndRemoveAnnotationComments :: GHC.ApiAnns -> GHC.SrcSpan+ -> ([GHC.Located GHC.AnnotationComment],GHC.ApiAnns)+getAndRemoveAnnotationComments (anns,canns) ss =+ (case Map.lookup ss canns of+ Just cs -> (cs,(anns,Map.delete ss canns))+ Nothing -> ([],(anns,canns)))+ `debug` ("getAndRemoveAnnotationComments:ss=" ++ showGhc ss)++----------------------------------------++getCommentsForSpan :: GHC.SrcSpan -> AP [Comment]+getCommentsForSpan s = AP (\l pe e ga ->+ let+ (gcs,ga1) = getAndRemoveAnnotationComments ga s+ cs = reverse $ map tokComment gcs+ tokComment :: GHC.Located GHC.AnnotationComment -> Comment+ tokComment t@(GHC.L lt _) = Comment (ghcIsMultiLine t) (ss2span lt) (ghcCommentText t)+ in (cs,l,pe,e,ga1,mempty)+ `debug` ("getCommentsForSpan:(s,cs)" ++ show (showGhc s,cs))+ )++-- -------------------------------------++-- |Add some annotation to the currently active SrcSpan+addAnnotationsAP :: Annotation -> AP ()+addAnnotationsAP ann = AP (\l pe e ga ->+ ( (),l,pe,e,ga,+ ([((ghead "addAnnotationsAP" l),ann)],[])))++-- -------------------------------------++addAnnDeltaPos :: (GHC.SrcSpan,KeywordId) -> DeltaPos -> AP ()+addAnnDeltaPos (s,kw) dp = AP (\l pe e ga -> ( (),+ l,pe,e,ga,+ ([],+ [ ((s,kw),[dp]) ]) ))++-- -------------------------------------++setFunIsInfix :: Bool -> AP ()+setFunIsInfix e = AP (\l pe _ ga -> ((),l,pe,e,ga,mempty))++getFunIsInfix :: AP Bool+getFunIsInfix = AP (\l pe e ga -> (e,l,pe,e,ga,mempty))++-- -------------------------------------++-- | 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))+ pushSrcSpanAP lss+ return ()+++-- | Pop up the SrcSpan stack, capture the annotations, and work the+-- comments in belonging to the span+-- Assumption: the annotations belong to the immediate sub elements of+-- the AST, hence relate to the current SrcSpan. They can thus be used+-- to decide which comments belong at this level,+-- The assumption is made valid by matching enterAST/leaveAST calls.+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++ priorEnd <- getPriorEnd++ newCs <- getCommentsForSpan ss+ co <- getCurrentColOffset+ let (lcs,_) = localComments co (ss2span ss) newCs []++ -- let dp = deltaFromSrcSpans priorEnd ss+ dp <- getCurrentDP+ addAnnotationsAP (Ann lcs dp) `debug` ("leaveAST:(ss,lcs,dp)=" ++ show (showGhc ss,lcs,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@(GHC.L l ast) = do+ enterAST a `debug` ("annotatePC:entering " ++ showGhc l)+ annotateP 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++-- ---------------------------------------------------------------------++isGoodDelta :: DeltaPos -> Bool+isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0++addFinalComments :: AP ()+addFinalComments = do+ return () `debug` ("addFinalComments:entering=")+ cs <- getCommentsForSpan GHC.noSrcSpan+ let (dcs,_) = localComments 1 ((1,1),(1,1)) cs []+ pushSrcSpanAP (GHC.L GHC.noSrcSpan ())+ addAnnotationsAP (Ann dcs (DP (0,0)))+ -- `debug` ("leaveAST:dcs=" ++ show dcs)+ return () `debug` ("addFinalComments:dcs=" ++ show dcs)++-- ---------------------------------------------------------------------++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 ()+ `debug` ("addDeltaAnnotationWorker::bad delta:(ss,ma,p,ann)=" ++ show (ss2span ss,ss2span pa,p,ann))+ (G GHC.AnnSemi,False) -> return ()+ `debug` ("addDeltaAnnotationWorker::bad delta:(ss,ma,p,ann)=" ++ show (ss2span ss,ss2span pa,p,ann))+ (G GHC.AnnOpen,False) -> return ()+ `debug` ("addDeltaAnnotationWorker::bad delta:(ss,ma,p,ann)=" ++ show (ss2span ss,ss2span pa,p,ann))+ (G GHC.AnnClose,False) -> return ()+ `debug` ("addDeltaAnnotationWorker::bad delta:(ss,ma,p,ann)=" ++ show (ss2span ss,ss2span pa,p,ann))+ _ -> do+ 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))+++-- | 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 ss 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 ss 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+ pe <- getPriorEnd+ ss <- getSrcSpanAP+ ma <- getAnnotationAP ss 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+ ss <- getSrcSpanAP+ ma <- getAnnotationAP ss 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 ss 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+ pe <- getPriorEnd+ ss <- getSrcSpanAP+ let p = deltaFromSrcSpans pe s+ p' <- adjustDeltaForOffsetM p+ addAnnDeltaPos (ss,G ann) p'+ setPriorEnd s++addEofAnnotation :: AP ()+addEofAnnotation = do+ pe <- getPriorEnd+ ss <- getSrcSpanAP+ ma <- getAnnotationAP GHC.noSrcSpan GHC.AnnEofPos+ case ma of+ [] -> return ()+ [pa] -> do+ 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+ ss <- getSrcSpanAP+ ma <- getAnnotationAP ss 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 (addFinalComments >> 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 -- '[' 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 -- ')'++-- ---------------------------------------------------------------------++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++ -- 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+ annotateHsLocalBinds lb++ annotateP _ (GHC.VarBind _n rhse _) = do+ -- Note: this bind is introduced by the typechecker+ annotatePC rhse++ annotateP _ (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 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+ 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+ addDeltaAnnotation GHC.AnnLet+ addDeltaAnnotation GHC.AnnOpenC -- '{'+ annotateHsLocalBinds lb+ addDeltaAnnotation GHC.AnnCloseC -- '}'++ 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 _) = do+ mapM_ annotatePC stmts++-- ---------------------------------------------------------------------++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.MatchGroup name (GHC.Located body))+ -> AP ()+annotateMatchGroup (GHC.MG matches _ _ _)+ = mapM_ annotatePC matches++-- ---------------------------------------------------------------------++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 _ (GHC.HsLam match) = do+ addDeltaAnnotation GHC.AnnLam+ annotateMatchGroup match++ annotateP _ (GHC.HsLamCase _ match) = annotateMatchGroup 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 _ (GHC.HsCase e1 matches) = do+ addDeltaAnnotation GHC.AnnCase+ annotatePC e1+ addDeltaAnnotation GHC.AnnOf+ addDeltaAnnotation GHC.AnnOpenC+ addDeltaAnnotationsInside GHC.AnnSemi+ annotateMatchGroup 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+ addDeltaAnnotation GHC.AnnLet+ startGroupingOffsets+ addDeltaAnnotation GHC.AnnOpenC+ addDeltaAnnotationsInside GHC.AnnSemi+ annotateHsLocalBinds binds+ addDeltaAnnotation GHC.AnnCloseC+ stopGroupingOffsets+ addDeltaAnnotation GHC.AnnIn+ annotatePC e++ annotateP _ (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+ mapM_ annotatePC 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 ()+++-- ---------------------------------------------------------------------++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 _ (GHC.HsCmdLam match) = do+ addDeltaAnnotation GHC.AnnLam+ annotateMatchGroup match++ annotateP _ (GHC.HsCmdPar e) = do+ addDeltaAnnotation GHC.AnnOpenP -- '('+ annotatePC e+ addDeltaAnnotation GHC.AnnCloseP -- ')'++ annotateP _ (GHC.HsCmdCase e1 matches) = do+ addDeltaAnnotation GHC.AnnCase+ annotatePC e1+ addDeltaAnnotation GHC.AnnOf+ addDeltaAnnotation GHC.AnnOpenC+ annotateMatchGroup 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+ annotateHsLocalBinds binds+ addDeltaAnnotation GHC.AnnCloseC+ addDeltaAnnotation GHC.AnnIn+ annotatePC e++ annotateP _ (GHC.HsCmdDo es _) = do+ addDeltaAnnotation GHC.AnnDo+ addDeltaAnnotation GHC.AnnOpenC+ mapM_ annotatePC 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.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.AnnUnit -- for empty context+ 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++-- ---------------------------------------------------------------------++-- | Given an enclosing Span @(p,e)@, and a list of sub SrcSpans @ds@,+-- identify all comments that are in @(p,e)@ but not in @ds@, and convert+-- them to be DComments relative to @p@+localComments :: Int -> Span -> [Comment] -> [Span] -> ([DComment],[Comment])+localComments co pin cs ds = r+ `debug` ("localComments:(p,ds,r):" ++ show ((p,e),ds,r))+ where+ r = (map (\c -> deltaComment co p c) matches,misses ++ missesRest)+ (p,e) = if pin == ((1,1),(1,1))+ then ((1,1),(99999999,1))+ else pin++ (matches,misses) = partition notSub cs'+ (cs',missesRest) = partition (\(Comment _ com _) -> isSubPos com (p,e)) cs++ notSub :: Comment -> Bool+ notSub (Comment _ com _) = not $ any (\sub -> isSubPos com sub) ds++ isSubPos (subs,sube) (parents,parente)+ = parents <= subs && parente >= sube++-- ---------------------------------------------------------------------++-- | Apply the delta to the current position, taking into account the+-- current column offset+undeltaComment :: Pos -> Int -> DComment -> Comment+undeltaComment l con dco@(DComment coo b (dps,dpe) s) = r+ `debug` ("undeltaComment:(l,con,dcomment,r)=" ++ show (l,con,dco,r))+ where+ r = Comment b ((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)++deltaComment :: Int -> Pos -> Comment -> DComment+deltaComment co l cin@(Comment b (s,e) str) = r+ `debug` ("deltaComment:(co,l,cin,r)=" ++ show (co,l,cin,r))+ where+ r = DComment co b ((ss2deltaP l s),(ss2deltaP l e)) str++-- | 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+undelta :: Pos -> DeltaPos -> Int -> Pos+undelta (l,c) (DP (dl,dc)) co = (fl,fc)+ where+ fl = l + dl+ fc = if dl == 0 then c + dc else co + dc++-- prop_delta :: TODO++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++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++{-+deriving instance Eq GHC.Token++ghcIsComment :: PosToken -> Bool+ghcIsComment ((GHC.L _ (GHC.ITdocCommentNext _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocCommentPrev _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocCommentNamed _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocSection _ _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocOptions _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITdocOptionsOld _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITlineComment _)),_s) = True+ghcIsComment ((GHC.L _ (GHC.ITblockComment _)),_s) = True+ghcIsComment ((GHC.L _ _),_s) = False+-}++ghcIsMultiLine :: GHC.Located GHC.AnnotationComment -> Bool+ghcIsMultiLine (GHC.L _ (GHC.AnnDocCommentNext _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnDocCommentPrev _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnDocCommentNamed _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnDocSection _ _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnDocOptions _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnDocOptionsOld _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnLineComment _)) = False+ghcIsMultiLine (GHC.L _ (GHC.AnnBlockComment _)) = True++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+#if __GLASGOW_HASKELL__ > 706+showGhc x = GHC.showPpr GHC.unsafeGlobalDynFlags x+#elif __GLASGOW_HASKELL__ > 704+showGhc x = GHC.showSDoc GHC.tracingDynFlags $ GHC.ppr x+#else+showGhc x = GHC.showSDoc $ GHC.ppr x+#endif+++-- |Show a GHC API structure+showGhcDebug :: (GHC.Outputable a) => a -> String+#if __GLASGOW_HASKELL__ > 706+showGhcDebug x = GHC.showSDocDebug GHC.unsafeGlobalDynFlags (GHC.ppr x)+#else+#if __GLASGOW_HASKELL__ > 704+showGhcDebug x = GHC.showSDoc GHC.tracingDynFlags $ GHC.ppr x+#else+showGhcDebug x = GHC.showSDoc $ GHC.ppr x+#endif+#endif++-- ---------------------------------------------------------------------++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++-- ---------------------------------------------------------------------++-- |For debugging+type OrganisedAnns = Map.Map GHC.SrcSpan ([(AnnConName,Annotation)]+ ,[(KeywordId, [DeltaPos])] )++-- | Re-arrange the annotations to make it clearer for users how they+-- hang together.+organiseAnns :: Anns -> OrganisedAnns+organiseAnns (anne,annf) = r+ where+ insertAnnE :: OrganisedAnns+ -> ((GHC.SrcSpan,AnnConName), Annotation)+ -> OrganisedAnns+ insertAnnE m ((ss,conName),ann) =+ case Map.lookup ss m of+ Just (cas,kds) -> Map.insert ss ((conName,ann):cas,kds) m+ Nothing -> Map.insert ss ([(conName,ann)], []) m+ insertAnnF m ((ss,kw),dps) =+ case Map.lookup ss m of+ Just (cas,kds) -> Map.insert ss (cas,(kw,dps):kds) m+ Nothing -> Map.insert ss ([], [(kw,dps)]) m+ re = foldl insertAnnE Map.empty (Map.toList anne)+ r = foldl insertAnnF re (Map.toList annf)++-- ---------------------------------------------------------------------++-- Based on ghc-syb-utils version, but adding the annotation+-- information to each SrcLoc.+showAnnData :: Data a => OrganisedAnns -> Int -> a -> String+showAnnData anns n =+ generic `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+ 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))))+ ++"}"++ 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+++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"++-- -------------------------------------------------------------------..+-- Copied from MissingH, does not compile with HEAD+++{- | Merge two sorted lists into a single, sorted whole.++Example:++> merge [1,3,5] [1,2,4,6] -> [1,1,2,3,4,5,6]++QuickCheck test property:++prop_merge xs ys =+ merge (sort xs) (sort ys) == sort (xs ++ ys)+ where types = xs :: [Int]+-}+merge :: (Ord a) => [a] -> [a] -> [a]+merge = mergeBy (compare)++{- | Merge two sorted lists using into a single, sorted whole,+allowing the programmer to specify the comparison function.++QuickCheck test property:++prop_mergeBy xs ys =+ mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)+ where types = xs :: [ (Int, Int) ]+ cmp (x1,_) (x2,_) = compare x1 x2+-}+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy _cmp [] ys = ys+mergeBy _cmp xs [] = xs+mergeBy cmp (allx@(x:xs)) (ally@(y:ys))+ -- Ordering derives Eq, Ord, so the comparison below is valid.+ -- Explanation left as an exercise for the reader.+ -- Someone please put this code out of its misery.+ | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally+ | otherwise = y : mergeBy cmp allx ys+
+ tests/Test.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE CPP #-}+-- | 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 GHC.Paths ( libdir )++import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified GHC as GHC+import qualified MonadUtils as GHC+import qualified Outputable as GHC++import qualified GHC.SYB.Utils as SYB++import Control.Monad+import System.Directory+import System.FilePath+import System.IO++import Test.HUnit++-- import qualified Data.Map as Map++-- ---------------------------------------------------------------------++main :: IO Counts+main = runTestTT tests++-- tests = TestCase (do r <- manipulateAstTest "examples/LetStmt.hs" "Layout.LetStmt"+-- assertBool "test" r )++tests = TestList+ [+ mkTestMod "examples/LetStmt.hs" "Layout.LetStmt"+ , mkTestMod "examples/LetExpr.hs" "LetExpr"+ , mkTestMod "examples/ExprPragmas.hs" "ExprPragmas"+ , mkTestMod "examples/ListComprehensions.hs" "Main"+ , mkTestMod "examples/MonadComprehensions.hs" "Main"+ , mkTestMod "examples/FunDeps.hs" "Main"+ , mkTestMod "examples/ImplicitParams.hs" "Main"+ , mkTestMod "examples/RecursiveDo.hs" "Main"+ , mkTestMod "examples/TypeFamilies.hs" "Main"+ , mkTestMod "examples/MultiParamTypeClasses.hs" "Main"+ , mkTestMod "examples/DataFamilies.hs" "DataFamilies"+ , mkTestMod "examples/Deriving.hs" "Main"+ , mkTestMod "examples/Default.hs" "Main"+ , mkTestMod "examples/ForeignDecl.hs" "ForeignDecl"+ , mkTestMod "examples/Warning.hs" "Warning"+ , mkTestMod "examples/Annotations.hs" "Annotations"+ , mkTestMod "examples/DocDecls.hs" "DocDecls"+ , mkTestModTH "examples/QuasiQuote.hs" "QuasiQuote"+ , mkTestMod "examples/Roles.hs" "Roles"+ , mkTestMod "examples/Splice.hs" "Splice"+ , mkTestMod "examples/ImportsSemi.hs" "ImportsSemi"+ , mkTestMod "examples/Stmts.hs" "Stmts"+ , mkTestMod "examples/Mixed.hs" "Main"+ , mkTestMod "examples/Arrow.hs" "Arrow"+ , mkTestMod "examples/PatSynBind.hs" "Main"+ , mkTestMod "examples/HsDo.hs" "HsDo"+ , mkTestMod "examples/ForAll.hs" "ForAll"+ , mkTestMod "examples/PArr.hs" "PArr"+ , mkTestMod "examples/ViewPatterns.hs" "Main"+ , mkTestMod "examples/BangPatterns.hs" "Main"+ , mkTestMod "examples/Associated.hs" "Main"+ , mkTestMod "examples/Move1.hs" "Move1"+ , mkTestMod "examples/Rules.hs" "Rules"+ , mkTestMod "examples/TypeOperators.hs" "Main"+ , mkTestMod "examples/NullaryTypeClasses.hs" "Main"+ , mkTestMod "examples/FunctionalDeps.hs" "Main"+ , mkTestMod "examples/DerivingOC.hs" "Main"+ , mkTestMod "examples/GenericDeriving.hs" "Main"+ , mkTestMod "examples/OverloadedStrings.hs" "Main"+ , mkTestMod "examples/RankNTypes.hs" "Main"+ , mkTestMod "examples/Existential.hs" "Main"+ , mkTestMod "examples/ScopedTypeVariables.hs" "Main"+ , mkTestMod "examples/Arrows.hs" "Main"+ , mkTestMod "examples/TH.hs" "Main"+ , mkTestMod "examples/StaticPointers.hs" "Main"+ , mkTestMod "examples/DataDecl.hs" "Main"+ , mkTestMod "examples/Guards.hs" "Main"+ , mkTestMod "examples/RebindableSyntax.hs" "Main"+ , mkTestMod "examples/RdrNames.hs" "RdrNames"+ , mkTestMod "examples/Vect.hs" "Vect"+ , mkTestMod "examples/Tuple.hs" "Main"+ , mkTestMod "examples/ExtraConstraints1.hs" "ExtraConstraints1"+ , mkTestMod "examples/AddAndOr3.hs" "AddAndOr3"+ , mkTestMod "examples/Ann01.hs" "Ann01"+ , mkTestMod "examples/StrictLet.hs" "Main"+ , mkTestMod "examples/Cg008.hs" "Cg008"+ , mkTestMod "examples/T2388.hs" "T2388"+ , mkTestMod "examples/T3132.hs" "T3132"+ , mkTestMod "examples/Stream.hs" "Stream"+ , mkTestMod "examples/Trit.hs" "Trit"+ , mkTestMod "examples/DataDecl.hs" "Main"+ , mkTestMod "examples/Zipper.hs" "Zipper"+ , mkTestMod "examples/Sigs.hs" "Sigs"+ , mkTestMod "examples/Utils2.hs" "Utils2"+ , mkTestMod "examples/EmptyMostlyInst.hs" "EmptyMostlyInst"+ , mkTestMod "examples/EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"+ , mkTestMod "examples/Dead1.hs" "Dead1"+ , mkTestMod "examples/EmptyMostly.hs" "EmptyMostly"+ , mkTestMod "examples/FromUtils.hs" "Main"+ , mkTestMod "examples/DocDecls.hs" "DocDecls"+ , mkTestMod "examples/RecordUpdate.hs" "Main"+ -- , mkTestMod "examples/Unicode.hs" "Main"+ , mkTestMod "examples/B.hs" "Main"+ , mkTestMod "examples/LayoutWhere.hs" "Main"+ , mkTestMod "examples/LayoutLet.hs" "Main"+ , mkTestMod "examples/Deprecation.hs" "Deprecation"+ , mkTestMod "examples/Infix.hs" "Main"+ , mkTestMod "examples/BCase.hs" "Main"+ , mkTestMod "examples/AltsSemis.hs" "Main"++ , mkTestMod "examples/LetExprSemi.hs" "LetExprSemi"+ ]++mkTestMain :: FilePath -> Test+mkTestMain fileName = TestCase (do r <- manipulateAstTest fileName "Main"+ assertBool fileName r )++mkTestMod :: FilePath -> String -> Test+mkTestMod fileName modName+ = TestCase (do r <- manipulateAstTest fileName modName+ assertBool fileName r )++mkTestModTH :: FilePath -> String -> Test+mkTestModTH fileName modName+ = TestCase (do r <- manipulateAstTestTH fileName modName+ assertBool fileName r )++-- ---------------------------------------------------------------------++t :: IO Bool+t = do++ manipulateAstTest "examples/LetStmt.hs" "Layout.LetStmt"+ manipulateAstTest "examples/LetExpr.hs" "LetExpr"+ manipulateAstTest "examples/ExprPragmas.hs" "ExprPragmas"+ manipulateAstTest "examples/ListComprehensions.hs" "Main"+ manipulateAstTest "examples/MonadComprehensions.hs" "Main"+ manipulateAstTest "examples/FunDeps.hs" "Main"+ manipulateAstTest "examples/ImplicitParams.hs" "Main"+ manipulateAstTest "examples/RecursiveDo.hs" "Main"+ manipulateAstTest "examples/TypeFamilies.hs" "Main"+ manipulateAstTest "examples/MultiParamTypeClasses.hs" "Main"+ manipulateAstTest "examples/DataFamilies.hs" "DataFamilies"+ manipulateAstTest "examples/Deriving.hs" "Main"+ manipulateAstTest "examples/Default.hs" "Main"+ manipulateAstTest "examples/ForeignDecl.hs" "ForeignDecl"+ manipulateAstTest "examples/Warning.hs" "Warning"+ manipulateAstTest "examples/Annotations.hs" "Annotations"+ manipulateAstTest "examples/DocDecls.hs" "DocDecls"+ manipulateAstTestTH "examples/QuasiQuote.hs" "QuasiQuote"+ manipulateAstTest "examples/Roles.hs" "Roles"+ manipulateAstTest "examples/Splice.hs" "Splice"+ manipulateAstTest "examples/ImportsSemi.hs" "ImportsSemi"+ manipulateAstTest "examples/Stmts.hs" "Stmts"+ manipulateAstTest "examples/Mixed.hs" "Main"+ manipulateAstTest "examples/Arrow.hs" "Arrow"+ manipulateAstTest "examples/PatSynBind.hs" "Main"+ manipulateAstTest "examples/HsDo.hs" "HsDo"+ manipulateAstTest "examples/ForAll.hs" "ForAll"+ manipulateAstTest "examples/PArr.hs" "PArr"+ manipulateAstTest "examples/ViewPatterns.hs" "Main"+ manipulateAstTest "examples/BangPatterns.hs" "Main"+ manipulateAstTest "examples/Associated.hs" "Main"+ manipulateAstTest "examples/Move1.hs" "Move1"+ manipulateAstTest "examples/Rules.hs" "Rules"+ manipulateAstTest "examples/TypeOperators.hs" "Main"+ manipulateAstTest "examples/NullaryTypeClasses.hs" "Main"+ manipulateAstTest "examples/FunctionalDeps.hs" "Main"+ manipulateAstTest "examples/DerivingOC.hs" "Main"+ manipulateAstTest "examples/GenericDeriving.hs" "Main"+ manipulateAstTest "examples/OverloadedStrings.hs" "Main"+ manipulateAstTest "examples/RankNTypes.hs" "Main"+ manipulateAstTest "examples/Existential.hs" "Main"+ manipulateAstTest "examples/ScopedTypeVariables.hs" "Main"+ manipulateAstTest "examples/Arrows.hs" "Main"+ manipulateAstTest "examples/TH.hs" "Main"+ manipulateAstTest "examples/StaticPointers.hs" "Main"+ manipulateAstTest "examples/DataDecl.hs" "Main"+ manipulateAstTest "examples/Guards.hs" "Main"+ manipulateAstTest "examples/RebindableSyntax.hs" "Main"+ manipulateAstTest "examples/RdrNames.hs" "RdrNames"+ manipulateAstTest "examples/Vect.hs" "Vect"+ manipulateAstTest "examples/Tuple.hs" "Main"+ manipulateAstTest "examples/ExtraConstraints1.hs" "ExtraConstraints1"+ manipulateAstTest "examples/AddAndOr3.hs" "AddAndOr3"+ manipulateAstTest "examples/Ann01.hs" "Ann01"+ manipulateAstTest "examples/StrictLet.hs" "Main"+ manipulateAstTest "examples/Cg008.hs" "Cg008"+ manipulateAstTest "examples/T2388.hs" "T2388"+ manipulateAstTest "examples/T3132.hs" "T3132"+ manipulateAstTest "examples/Stream.hs" "Stream"+ manipulateAstTest "examples/Trit.hs" "Trit"+ manipulateAstTest "examples/DataDecl.hs" "Main"+ manipulateAstTest "examples/Zipper.hs" "Zipper"+ manipulateAstTest "examples/Sigs.hs" "Sigs"+ manipulateAstTest "examples/Utils2.hs" "Utils2"+ manipulateAstTest "examples/EmptyMostlyInst.hs" "EmptyMostlyInst"+ manipulateAstTest "examples/EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"+ manipulateAstTest "examples/Dead1.hs" "Dead1"+ manipulateAstTest "examples/EmptyMostly.hs" "EmptyMostly"+ manipulateAstTest "examples/FromUtils.hs" "Main"+ manipulateAstTest "examples/DocDecls.hs" "DocDecls"+ manipulateAstTest "examples/RecordUpdate.hs" "Main"+ -- manipulateAstTest "examples/Unicode.hs" "Main"+ manipulateAstTest "examples/B.hs" "Main"+ manipulateAstTest "examples/LayoutWhere.hs" "Main"+ manipulateAstTest "examples/LayoutLet.hs" "Main"+ manipulateAstTest "examples/Deprecation.hs" "Deprecation"+ manipulateAstTest "examples/Infix.hs" "Main"+ manipulateAstTest "examples/BCase.hs" "Main"+ manipulateAstTest "examples/AltsSemis.hs" "Main"++ manipulateAstTest "examples/LetExprSemi.hs" "LetExprSemi"+{-+ manipulateAstTest "examples/Cpp.hs" "Main"+ manipulateAstTest "examples/Lhs.lhs" "Main"+ manipulateAstTest "examples/ParensAroundContext.hs" "ParensAroundContext"+ manipulateAstTest "examples/EmptyMostly2.hs" "EmptyMostly2"+ manipulateAstTest "examples/Foo.hs" "Main"+-}++-- | Where all the tests are to be found+examplesDir :: FilePath+examplesDir = "tests" </> "examples"++examplesDir2 :: FilePath+examplesDir2 = "examples"++manipulateAstTest :: FilePath -> String -> IO Bool+manipulateAstTest file modname = manipulateAstTest' False file modname++manipulateAstTestTH :: FilePath -> String -> IO Bool+manipulateAstTestTH file modname = manipulateAstTest' True file modname++manipulateAstTest' :: Bool -> FilePath -> String -> IO Bool+manipulateAstTest' useTH file modname = do+ let out = file <.> "out"+ golden = file <.> "golden"++ contents <- readUTF8File file+ (ghcAnns,t) <- parsedFileGhc file modname useTH+ let+ parsed@(GHC.L l hsmod) = GHC.pm_parsed_source $ GHC.tm_parsed_module t+ parsedAST = SYB.showData SYB.Parser 0 parsed+ -- 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+ `debug` ("ghcAnns:" ++ showGhc ghcAnns)++ Just (GHC.L le exps) = GHC.hsmodExports hsmod+ secondExp@(GHC.L l2 _) = ghead "foo" $ tail exps+ ss = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") 16 9)+ (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") 16 27)++ printed = exactPrintAnnotation parsed [] ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))+ result =+ if printed == contents+ then "Match\n"+ else printed ++ "\n==============\n"+ ++ "lengths:" ++ show (length printed,length contents) ++ "\n"+ ++ parsedAST+ -- putStrLn $ "Test:parsed=" ++ parsedAST+ writeFile out $ result+ -- putStrLn $ "Test:ann organised:" ++ showGhc (organiseAnns ann)+ -- putStrLn $ "Test:showdata:" ++ showAnnData (organiseAnns ann) 0 parsed+ return ("Match\n" == result)+-- }}}+++-- ---------------------------------------------------------------------+-- |Result of parsing a Haskell source file. It is simply the+-- TypeCheckedModule produced by GHC.+type ParseResult = GHC.TypecheckedModule++parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult)+parsedFileGhc fileName modname useTH = do+ putStrLn $ "parsedFileGhc:" ++ show fileName+#if __GLASGOW_HASKELL__ > 704+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do+#else+ GHC.defaultErrorHandler GHC.defaultLogAction $ do+#endif+ GHC.runGhc (Just libdir) $ do+ dflags <- GHC.getSessionDynFlags+ let dflags' = foldl GHC.xopt_set dflags+ [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash]++ dflags'' = dflags' { GHC.importPaths = ["./tests/examples/","../tests/examples/",+ "./src/","../src/"] }++ tgt = if useTH then GHC.HscInterpreted+ else GHC.HscNothing -- allows FFI+ dflags''' = dflags'' { GHC.hscTarget = tgt,+ GHC.ghcLink = GHC.LinkInMemory+ , GHC.packageFlags = [GHC.ExposePackage (GHC.PackageArg "ghc") (GHC.ModRenaming False [])]+ }++ dflags4 = if False -- useHaddock+ then GHC.gopt_set (GHC.gopt_set dflags''' GHC.Opt_Haddock)+ GHC.Opt_KeepRawTokenStream+ else GHC.gopt_set dflags'''+ GHC.Opt_KeepRawTokenStream+ -- else GHC.gopt_set (GHC.gopt_unset dflags''' GHC.Opt_Haddock)+ -- GHC.Opt_KeepRawTokenStream++ (dflags5,args,warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"]+ GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc args,map GHC.unLoc warns)+ void $ GHC.setSessionDynFlags dflags5+ -- GHC.liftIO $ putStrLn $ "dflags set"++ target <- GHC.guessTarget fileName Nothing+ GHC.setTargets [target]+ GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target)+ void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make+ -- GHC.liftIO $ putStrLn $ "targets loaded"+ g <- GHC.getModuleGraph+ let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms)+ -- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g))++ modSum <- GHC.getModSummary $ GHC.mkModuleName modname+ -- GHC.liftIO $ putStrLn $ "got modSum"+ -- let modSum = head g+ p <- GHC.parseModule modSum+ -- GHC.liftIO $ putStrLn $ "got parsedModule"+ t <- GHC.typecheckModule p+ GHC.liftIO $ putStrLn $ "typechecked"+ -- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum)+ -- GHC.liftIO $ putStrLn $ "toks"+ let anns = GHC.pm_annotations p+ GHC.liftIO $ putStrLn $ "anns"+ return (anns,t)++readUTF8File :: FilePath -> IO String+readUTF8File fp = openFile fp ReadMode >>= \h -> do+ hSetEncoding h utf8+ hGetContents h++-- ---------------------------------------------------------------------++pwd :: IO FilePath+pwd = getCurrentDirectory++cd :: FilePath -> IO ()+cd = setCurrentDirectory++-- ---------------------------------------------------------------------++mkSs :: (Int,Int) -> (Int,Int) -> GHC.SrcSpan+mkSs (sr,sc) (er,ec)+ = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") sr sc)+ (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") er ec)