diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal new file mode 100644 --- /dev/null +++ b/ghc-exactprint.cabal @@ -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 + + diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -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) "#-}" + +-- --------------------------------------------------------------------- + + diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -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) diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -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 + diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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)