diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: ghc-exactprint -version: 0.1.0.1 +version: 0.1.1.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 @@ -17,7 +17,7 @@ license: BSD3 license-file: LICENSE -author: Alan Zimmerman +author: Alan Zimmerman, Matt Pickering maintainer: alan.zimm@gmail.com -- copyright: category: Development @@ -33,8 +33,12 @@ -- other-extensions: build-depends: base >=4.7 && <4.9 , containers + , directory + , filepath , ghc , ghc-paths + , ghc-syb-utils + , mtl , syb hs-source-dirs: src default-language: Haskell2010 @@ -48,18 +52,19 @@ 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 + Build-depends: HUnit + , base < 5 + , containers + , directory + , filepath + , ghc + , ghc-exactprint + , ghc-paths + , ghc-syb-utils + , mtl + , random + , stm + , syb source-repository head type: git diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -6,19 +6,8 @@ ----------------------------------------------------------------------------- -- | -- 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. +-- Based on Language.Haskell.Exts.Annotated.ExactPrint -- ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint @@ -35,16 +24,17 @@ import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils -import Control.Monad (when, liftM, ap) +import Control.Applicative import Control.Exception +import Control.Monad.RWS import Data.Data import Data.List --- import Data.List.Utils -- TODO: Reinstate when available +import Data.Maybe import qualified Bag as GHC import qualified BasicTypes as GHC import qualified Class as GHC -import qualified CoAxiom as GHC +import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC @@ -88,8 +78,6 @@ startLine = srcSpanStartLine startColumn = srcSpanStartColumn - - class Annotated a where ann :: a -> GHC.SrcSpan @@ -99,145 +87,181 @@ ------------------------------------------------------ -- 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 - } +-- The (ColOffset,ColOffset) value carries the normal and current +-- column offset. The second one captures the difference between the +-- original col when the DP was captured and the current one. -initExtra :: Extra -initExtra = E (False,"") False +data EPState = EPState + { epPos :: Pos -- ^ Current output position + , epAnns :: Anns + , epAnnKds :: [[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local state with suitable refactoring? + -- AZ, it is already in the last element of Annotation, for withOffset + } -instance Functor EP where - fmap = liftM +data EPLocal = EPLocal + { eFunId :: (Bool, String) + , eFunIsInfix :: Bool -- AZ:Needed? is in first field of eFunId + , epStack :: (ColOffset,ColDelta) -- ^ stack of offsets that currently apply + , epSrcSpan :: GHC.SrcSpan + } -instance Applicative EP where - pure = return - (<*>) = ap +type EP a = RWS EPLocal (Endo String) EPState a -instance Monad EP where - return x = EP $ \l dp s cs st an -> (x, l, dp, s, cs, st, an, id) +runEP :: EP () -> GHC.SrcSpan -> Anns -> String +runEP f ss ans = + flip appEndo "" . snd . execRWS f (defaultLocal ss) $ (defaultState ans) - 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) +defaultState :: Anns -> EPState +defaultState as = EPState + { epPos = (1,1) + , epAnns = as + , epAnnKds = [] + } -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 "" +defaultLocal :: GHC.SrcSpan -> EPLocal +defaultLocal ss = EPLocal + { eFunId = (False, "") + , eFunIsInfix = False + , epStack = (0,0) + , epSrcSpan = ss + } getPos :: EP Pos -getPos = EP (\l dp s cs st an -> (l,l,dp,s,cs,st,an,id)) +getPos = gets epPos setPos :: Pos -> EP () -setPos l = EP (\_ dp s cs st an -> ((),l,dp,s,cs,st,an,id)) +setPos l = modify (\s -> s {epPos = l}) -- --------------------------------------------------------------------- --- 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 -> +-- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous +-- offset +-- +withOffset :: Annotation -> (EP () -> EP ()) +withOffset a@(Ann (DP (edLine, edColumn)) newline originalStartCol annDelta _) k = do + -- The colOffset is the offset to be used when going to the next line. + -- The colIndent is how far the current code block has been indented. + (colOffset, colIndent) <- asks epStack + (_l, currentColumn) <- getPos let - (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') - ) + -- Add extra indentation for this SrcSpan + colOffset' = annDelta + colOffset + -- Work out where new column starts, based on the entry delta + newStartColumn = if edLine == 0 + then edColumn + currentColumn -- same line, use entry delta + else colOffset -- different line, use current offset + newColIndent = newStartColumn - originalStartCol -popOffset :: EP () -popOffset = EP (\l (_o:dp) s cs st an -> ((),l,dp,s,cs,st,an,id) - `debug` ("popOffset:co=" ++ show (fst _o)) - ) + offsetValNewIndent = (colOffset' + (newColIndent - colIndent), newColIndent) + offsetValSameIndent = (colOffset' , colIndent) + offsetValNewline = (annDelta + colIndent, colIndent) --- --------------------------------------------------------------------- + newOffset = + case newline of + -- For use by AST modifiers, to preserve the indentation + -- level for the next line after an AST modification + KeepOffset -> offsetValNewline -pushSrcSpan :: GHC.SrcSpan -> EP () -pushSrcSpan ss = EP (\l dp sss cs st an -> ((),l,dp,(ss:sss),cs,st,an,id)) + -- Generated during the annotation phase + LineChanged -> offsetValNewline + LayoutLineChanged -> offsetValNewline -popSrcSpan :: EP () -popSrcSpan = EP (\l dp (_:sss) cs st an -> ((),l,dp,sss,cs,st,an,id)) + LineSame -> offsetValSameIndent + LayoutLineSame -> offsetValNewIndent + local (\s -> s {epStack = newOffset }) k + `debug` ("pushOffset:(a, colOffset, colIndent, currentColumn, newOffset)=" + ++ show (a, colOffset, colIndent, currentColumn, newOffset)) +-- |Get the current column offset +getOffset :: EP ColOffset +getOffset = asks (fst . epStack) -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)) +-- --------------------------------------------------------------------- +withSrcSpan :: GHC.SrcSpan -> (EP () -> EP ()) +withSrcSpan ss = local (\s -> s {epSrcSpan = ss}) + 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)) +getAndRemoveAnnotation a = do + (r, an') <- gets (getAndRemoveAnnotationEP a . epAnns) + modify (\s -> s { epAnns = an' }) + return r +withKds :: [(KeywordId, DeltaPos)] -> EP () -> EP () +withKds kd action = do + modify (\s -> s { epAnnKds = kd : (epAnnKds s) }) + action + modify (\s -> s { epAnnKds = tail (epAnnKds s) }) +-- | Get and remove the first item in the (k,v) list for which the k matches. +-- Return the value, together with any comments skipped over to get there. +destructiveGetFirst :: KeywordId -> ([(KeywordId,v)],[(KeywordId,v)]) + -> ([(KeywordId,v)],[v],[(KeywordId,v)]) +destructiveGetFirst _key (acc,[]) = ([],[],acc) +destructiveGetFirst key (acc,((k,v):kvs)) + | k == key = let (cs,others) = commentsAndOthers acc in (cs,[v],others++kvs) + | otherwise = destructiveGetFirst key (acc++[(k,v)],kvs) + where + commentsAndOthers kvs' = partition isComment kvs' + isComment ((AnnComment _),_) = True + isComment _ = False + -- |destructive get, hence use an annotation once only -getAnnFinal :: KeywordId -> EP [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)) +getAnnFinal :: KeywordId -> EP ([DComment], [DeltaPos]) +getAnnFinal kw = do + kd <- gets epAnnKds + let (r, kd', dcs) = case kd of + [] -> ([],[], []) + (k:kds) -> (r',kk:kds, dcs') + where (cs', r',kk) = destructiveGetFirst kw ([],k) + dcs' = concatMap keywordIdToDComment cs' + modify (\s -> s { epAnnKds = kd' }) + return (dcs, r) --- |non-destructive get, hence use an annotation once only +-- --------------------------------------------------------------------- + +getStoredListSrcSpan :: EP GHC.SrcSpan +getStoredListSrcSpan = do + kd <- gets epAnnKds + let + isAnnList ((AnnList _),_) = True + isAnnList _ = False + + kdf = ghead "getStoredListSrcSpan.1" kd + (AnnList ss,_) = ghead "getStoredListSrcSpan.2" $ filter isAnnList kdf + return ss + +-- --------------------------------------------------------------------- + +keywordIdToDComment :: (KeywordId, DeltaPos) -> [DComment] +keywordIdToDComment (AnnComment comment,_dp) = [comment] +keywordIdToDComment _ = [] + +-- |non-destructive get peekAnnFinal :: KeywordId -> EP [DeltaPos] -peekAnnFinal kw = 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)) +peekAnnFinal kw = do + (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds) + return r getFunId :: EP (Bool,String) -getFunId = EP (\l dp s cs st an -> (eFunId st,l,dp,s,cs,st,an,id)) +getFunId = asks eFunId -setFunId :: (Bool,String) -> EP () -setFunId st = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunId = st},an,id)) +withFunId :: (Bool,String) -> (EP () -> EP ()) +withFunId st = local (\s -> s{eFunId = st}) getFunIsInfix :: EP Bool -getFunIsInfix = EP (\l dp s cs e an -> (eFunIsInfix e,l,dp,s,cs,e,an,id)) +getFunIsInfix = asks eFunIsInfix -setFunIsInfix :: Bool -> EP () -setFunIsInfix b = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunIsInfix = b},an,id)) +withFunIsInfix :: Bool -> (EP () -> EP ()) +withFunIsInfix b = local (\s -> s {eFunIsInfix = b}) -- --------------------------------------------------------------------- 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)) +printString str = do + (l,c) <- gets epPos + setPos (l, c + length str) + tell (Endo $ showString str) newLine :: EP () newLine = do @@ -253,47 +277,29 @@ | 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 +printWhitespace p = do + -- mPrintComments p >> padUntil p + padUntil p printStringAt :: Pos -> String -> EP () printStringAt p str = printWhitespace p >> printString str -- --------------------------------------------------------------------- -printStringAtLsDelta :: [DeltaPos] -> String -> EP () -printStringAtLsDelta mc s = +-- |This should be the final point where things are mode concrete, +-- before output. Hence the point where comments can be inserted +printStringAtLsDelta :: [DComment] -> [DeltaPos] -> String -> EP () +printStringAtLsDelta cs mc s = case reverse mc of (cl:_) -> do p <- getPos colOffset <- getOffset - -- if isGoodDelta cl if isGoodDeltaWithOffset cl colOffset - then printStringAt (undelta p cl colOffset) s + then do + mapM_ printQueuedComment cs + printStringAt (undelta p cl colOffset) s + `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (mc,s)) _ -> return () @@ -301,22 +307,43 @@ isGoodDeltaWithOffset :: DeltaPos -> Int -> Bool isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset)) +-- AZ:TODO: harvest the commonality between this and printStringAtLsDelta +printQueuedComment :: DComment -> EP () +printQueuedComment (DComment (dp,de) s) = do + p <- getPos + colOffset <- getOffset + let (dr,dc) = undelta (0,0) dp colOffset + if isGoodDelta (DP (dr,max 0 dc)) -- do not lose comments against the left margin + then do + printStringAt (undelta p dp colOffset) s + `debug` ("printQueuedComment:(pos,s):" ++ show (undelta p dp colOffset,s)) + setPos (undelta p de colOffset) + else return () `debug` ("printQueuedComment::bad delta for (dp,s):" ++ show (dp,s)) + -- --------------------------------------------------------------------- +getPosForDelta :: DeltaPos -> EP Pos +getPosForDelta dp = do + p <- getPos + colOffset <- getOffset + return (undelta p dp colOffset) + +-- --------------------------------------------------------------------- + printStringAtMaybeAnn :: KeywordId -> String -> EP () printStringAtMaybeAnn an str = do - ma <- getAnnFinal an - printStringAtLsDelta ma str + (comments, ma) <- getAnnFinal an + printStringAtLsDelta comments ma str `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str)) printStringAtMaybeAnnAll :: KeywordId -> String -> EP () printStringAtMaybeAnnAll an str = go where go = do - ma <- getAnnFinal an + (comments, ma) <- getAnnFinal an case ma of [] -> return () - [d] -> printStringAtLsDelta [d] str >> go + [d] -> printStringAtLsDelta comments [d] str >> go -- --------------------------------------------------------------------- @@ -330,54 +357,48 @@ -- | 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) +exactPrint :: (ExactP ast) => GHC.Located ast -> String +exactPrint ast@(GHC.L l _) = runEP (exactPC ast) l Map.empty exactPrintAnnotated :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> String -exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (loadInitialComments >> exactPC ast) l [] an +exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (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 + GHC.Located ast -> Anns -> String +exactPrintAnnotation ast@(GHC.L l _) an = runEP (exactPC ast) l an -- `debug` ("exactPrintAnnotation:an=" ++ (concatMap (\(l,a) -> show (ss2span l,a)) $ Map.toList an )) annotateAST :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> Anns annotateAST ast ghcAnns = annotateLHsModule ast ghcAnns -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 :: (ExactP ast) => GHC.Located ast -> EP () exactPC a@(GHC.L l ast) = - do pushSrcSpan l `debug` ("exactPC entered for:" ++ showGhc l) - -- ma <- getAnnotation a + do return () `debug` ("exactPC entered for:" ++ showGhc l) 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 + let an@(Ann _edp _nl _sc _dc kds) = fromMaybe annNone ma + withContext kds l an + (do + exactP ast + printStringAtMaybeAnn (G GHC.AnnComma) "," + printStringAtMaybeAnnAll AnnSemiSep ";") + epStack' <- asks epStack + return () `debug` ("popOffset:after pop:(l,epStack')=" ++ showGhc (l,epStack')) - popSrcSpan +withContext :: [(KeywordId, DeltaPos)] + -> GHC.SrcSpan + -> Annotation + -> (EP () -> EP ()) +withContext kds l an = withKds kds . withSrcSpan l . withOffset an +-- --------------------------------------------------------------------- printMerged :: (ExactP a, ExactP b) => [GHC.Located a] -> [GHC.Located b] -> EP () printMerged [] [] = return () @@ -854,17 +875,19 @@ 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 + withFunId (isSymbolRdrName n,rdrName2String n) ( + withFunIsInfix isInfix + (mapM_ exactPC matches)) exactP (GHC.PatBind lhs (GHC.GRHSs grhs lb) _ty _fvs _ticks) = do exactPC lhs printStringAtMaybeAnn (G GHC.AnnEqual) "=" mapM_ exactPC grhs printStringAtMaybeAnn (G GHC.AnnWhere) "where" - exactP lb + -- exactP lb + exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) + exactP (GHC.VarBind _var_id _var_rhs _var_inline ) = printString "VarBind" exactP (GHC.AbsBinds _abs_tvs _abs_ev_vars _abs_exports _abs_ev_binds _abs_binds) = printString "AbsBinds" @@ -932,7 +955,8 @@ printStringAtMaybeAnn (G GHC.AnnWhere) "where" printStringAtMaybeAnn (G GHC.AnnOpenC) "{" printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - exactP lb + -- exactP lb + exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) printStringAtMaybeAnn (G GHC.AnnCloseC) "}" -- --------------------------------------------------------------------- @@ -1232,7 +1256,7 @@ exactP (GHC.LetStmt lb) = do printStringAtMaybeAnn (G GHC.AnnLet) "let" printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactP lb + exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) printStringAtMaybeAnn (G GHC.AnnCloseC) "}" exactP (GHC.ParStmt pbs _ _) = do @@ -1331,13 +1355,16 @@ mapM_ exactPC rhs exactP (GHC.HsLet lb e) = do + return () `debug` ("exactP.HsLet started") printStringAtMaybeAnn (G GHC.AnnLet) "let" printStringAtMaybeAnn (G GHC.AnnOpenC) "{" printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - exactP lb + exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) + return () `debug` ("exactP.HsLet lb done") printStringAtMaybeAnn (G GHC.AnnCloseC) "}" printStringAtMaybeAnn (G GHC.AnnIn) "in" exactPC e + return () `debug` ("exactP.HsLet ended") exactP (GHC.HsDo cts stmts _typ) = do printStringAtMaybeAnn (G GHC.AnnDo) "do" @@ -1358,7 +1385,8 @@ printStringAtMaybeAnn (G GHC.AnnVbar) "|" mapM_ exactPC (init stmts) else do - mapM_ exactPC stmts + ss <- getStoredListSrcSpan + exactPC (GHC.L ss stmts) printStringAtMaybeAnn (G GHC.AnnCloseS) "]" printStringAtMaybeAnn (G GHC.AnnClose) cstr printStringAtMaybeAnn (G GHC.AnnCloseC) "}" @@ -1570,6 +1598,11 @@ -- --------------------------------------------------------------------- +instance ExactP ([GHC.ExprLStmt GHC.RdrName]) where + exactP ls = mapM_ exactPC ls + +-- --------------------------------------------------------------------- + instance (ExactP arg) => ExactP (GHC.HsRecField GHC.RdrName (GHC.Located arg)) where exactP (GHC.HsRecField n e _) = do exactPC n @@ -1632,7 +1665,8 @@ exactP (GHC.HsCmdLet lb e) = do printStringAtMaybeAnn (G GHC.AnnLet) "let" printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactP lb + -- exactP lb + exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) printStringAtMaybeAnn (G GHC.AnnCloseC) "}" printStringAtMaybeAnn (G GHC.AnnIn) "in" exactPC e @@ -1640,13 +1674,20 @@ exactP (GHC.HsCmdDo stmts _typ) = do printStringAtMaybeAnn (G GHC.AnnDo) "do" printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - mapM_ exactPC stmts + -- mapM_ exactPC stmts + ss <- getStoredListSrcSpan + exactPC (GHC.L ss stmts) printStringAtMaybeAnn (G GHC.AnnCloseC) "}" exactP (GHC.HsCmdCast {}) = error $ "exactP.HsCmdCast: only valid after type checker" -- --------------------------------------------------------------------- +instance ExactP [GHC.CmdLStmt GHC.RdrName] where + exactP ls = mapM_ exactPC ls + +-- --------------------------------------------------------------------- + instance ExactP GHC.RdrName where exactP n = do case rdrName2String n of @@ -1683,8 +1724,14 @@ exactPMatchGroup :: (ExactP body) => (GHC.MatchGroup GHC.RdrName (GHC.Located body)) -> EP () -exactPMatchGroup (GHC.MG matches _ _ _) - = mapM_ exactPC matches +exactPMatchGroup (GHC.MG matches _ _ _) = do + ss <- getStoredListSrcSpan + exactPC (GHC.L ss matches) + +-- --------------------------------------------------------------------- + +instance ExactP body => (ExactP [GHC.LMatch GHC.RdrName (GHC.Located body)]) where + exactP ls = mapM_ exactPC ls -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.GHC.ExactPrint.Types @@ -11,27 +9,27 @@ , Span , PosToken , DeltaPos(..) + , ColOffset,ColDelta,Col + , LineChanged(..) , Annotation(..) + , combineAnns , annNone - , Anns,anEP,anF - , AnnsEP - , AnnsFinal + , Anns,AnnKey(..) , KeywordId(..) + , mkAnnKey , AnnConName(..) , annGetConstr , unConName , ResTyGADTHook(..) - , AnnKey - , AnnKeyF - , mkAnnKeyEP , getAnnotationEP , getAndRemoveAnnotationEP ) where import Data.Data +import Data.Monoid import qualified GHC as GHC import qualified Outputable as GHC @@ -40,76 +38,116 @@ -- --------------------------------------------------------------------- --- | A Haskell comment. The 'Bool' is 'True' if the comment is multi-line, i.e. @{- -}@. -data Comment = Comment Bool Span String +-- | A Haskell comment. +data Comment = Comment 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 GHC.Outputable Comment where + ppr x = GHC.text (show x) +-- |Delta version of the comment. +data DComment = DComment (DeltaPos,DeltaPos) String + deriving (Eq,Show,Typeable,Data,Ord) + instance Ord Comment where - compare (Comment _ p1 _) (Comment _ p2 _) = compare p1 p2 + 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) +data DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) +type ColOffset = Int -- ^ indentation point for a new line +type ColDelta = Int -- ^ difference between two cols +type Col = Int annNone :: Annotation -annNone = Ann [] (DP (0,0)) +annNone = Ann (DP (0,0)) LineSame 0 0 [] +combineAnns :: Annotation -> Annotation -> Annotation +combineAnns (Ann ed1 nl1 c1 dp1 dps1) (Ann _ed2 _nl2 _c2 _dp2 dps2) + = Ann ed1 nl1 c1 dp1 (dps1 ++ dps2) + +data LineChanged = LineSame | LineChanged + | KeepOffset -- ^ For use in AST editing + | LayoutLineSame | LayoutLineChanged -- experimental, may replace LineSame and LineChanged + deriving (Show,Eq,Typeable) + data Annotation = Ann - { ann_comments :: ![DComment] - , ann_delta :: !DeltaPos -- Do we need this? Yes indeed. - } deriving (Show,Typeable) + { + ann_entry_delta :: !DeltaPos -- ^ Offset used to get to the start + -- of the SrcSpan, during the + -- annotatePC phase + , ann_original_nl :: !LineChanged -- ^ Did the original span start + -- on a new line wrt to the prior + -- one? + , ann_original_col :: !Col -- ^ Start of the SrcSpan, as used + -- during the annotatePC phase + , ann_delta :: !ColOffset -- ^ Indentation level introduced + -- by this SrcSpan, for other items + -- at same layout level + , anns :: [(KeywordId, DeltaPos)] -- TODO:AZ change this to ann_dps + } deriving (Typeable,Eq) +instance Show Annotation where + show (Ann dp nl c d ans) = "(Ann (" ++ show dp ++ ") " ++ show nl ++ " " ++ show c ++ " " ++ show d ++ " " ++ show ans ++ ")" + +instance Monoid Annotation where + mempty = annNone + mappend = combineAnns + + 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 +type Anns = Map.Map AnnKey Annotation +-- | 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 +data AnnKey = AnnKey GHC.SrcSpan AnnConName + deriving (Eq, Show, Ord) + +mkAnnKey :: (Data a) => GHC.Located a -> AnnKey +mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a) + -- 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) +{- +annGetConstr a = CN con + where + -- map all RdrName constuctors to the same field. + con = case show $ toConstr a of + "Unqual" -> "RdrName" + "Qual" -> "RdrName" + "Orig" -> "RdrName" + "Exact" -> "RdrName" + s -> s +-} unConName :: AnnConName -> String unConName (CN s) = s - - --- | 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 + | AnnComment DComment + | AnnList GHC.SrcSpan -- ^ In some circumstances we + -- need to annotate a list of + -- statements (e.g. HsDo) and + -- must synthesise a SrcSpan to + -- hang the annotations off. This + -- needs to be preserved so that + -- exactPC can find it, after + -- potential AST edits. deriving (Eq,Show,Ord) -- --------------------------------------------------------------------- @@ -123,6 +161,9 @@ instance GHC.Outputable Annotation where ppr a = GHC.text (show a) +instance GHC.Outputable AnnKey where + ppr a = GHC.text (show a) + instance GHC.Outputable DeltaPos where ppr a = GHC.text (show a) @@ -140,15 +181,15 @@ -- --------------------------------------------------------------------- -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 +getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation +getAnnotationEP (GHC.L ss a) anns = Map.lookup (AnnKey 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) + => GHC.Located a -> Anns -> (Maybe Annotation,Anns) +getAndRemoveAnnotationEP (GHC.L ss a) anns + = let key = AnnKey ss (annGetConstr a) in + case Map.lookup key anns of + Nothing -> (Nothing,anns) + Just av -> (Just av,Map.delete key anns) + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -1,27 +1,23 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.GHC.ExactPrint.Utils ( annotateLHsModule - , organiseAnns - , OrganisedAnns - - -- , ghcIsComment - , ghcIsMultiLine - , srcSpanStartLine , srcSpanEndLine , srcSpanStartColumn , srcSpanEndColumn + , getListSrcSpan + , getLocalBindsSrcSpan , ss2span , ss2pos , ss2posEnd + , span2ss , undelta , undeltaComment , isGoodDelta @@ -33,13 +29,12 @@ , showGhc , showAnnData - , merge -- * For tests , debug , runAP - , AP(..) + , AP , getSrcSpanAP, pushSrcSpanAP, popSrcSpanAP , getAnnotationAP , addAnnotationsAP @@ -51,12 +46,13 @@ ) where -import Control.Monad ( liftM, ap) +import Control.Monad.State +import Control.Monad.Writer +import Control.Applicative import Control.Exception import Data.Data import Data.Generics import Data.List -import Data.Monoid import Language.Haskell.GHC.ExactPrint.Types @@ -88,77 +84,98 @@ -- --------------------------------------------------------------------- + +data APState = APState + { -- | A stack to the root of the AST. + apStack :: [StackItem] + , priorEndPosition :: GHC.SrcSpan + -- | Ordered list of comments still to be allocated + , apComments :: [Comment] + -- | isInfix for a FunBind + -- AZ: Is this still needed? + , e_is_infix :: Bool + -- | The original GHC API Annotations + , apAnns :: GHC.ApiAnns + } + +data StackItem = StackItem + { -- | Current `SrcSpan` + curSrcSpan :: GHC.SrcSpan + -- | The offset required to get from the prior end point to the + -- start of the current SrcSpan. Accessed via `getEntryDP` + , offset :: DeltaPos + -- | Offsets for the elements annotated in this `SrcSpan` + , annOffsets :: [(KeywordId, DeltaPos)] + -- | Indicates whether the contents of this SrcSpan are + -- subject to vertical alignment layout rules + , curLayoutOn :: Bool + -- | The constructor name of the AST element, to + -- distinguish between nested elements that have the same + -- `SrcSpan` in the AST. + , annConName :: AnnConName + } + +defaultAPState :: GHC.ApiAnns -> APState +defaultAPState ga = + let cs = flattenedComments ga in + APState + { apStack = [] + , priorEndPosition = GHC.noSrcSpan + , apComments = cs + , e_is_infix = False -- ^ AZ: Is this still needed? isInfix for a FunBind + , apAnns = ga -- $ + } + -- | Type used in the AP Monad. The state variables maintain -- - the current SrcSpan and the constructor of the thing it encloses -- as a stack to the root of the AST as it is traversed, -- - the srcspan of the last thing annotated, to calculate delta's from -- - extra data needing to be stored in the monad -- - the annotations provided by GHC +type AP a = StateT APState (Writer [(AnnKey, Annotation)]) a -{- -} -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])]) - )) +data Grouping = None | Primed GHC.SrcSpan | Active DeltaPos | Done DeltaPos + deriving (Eq,Show) --- 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) +runAP :: AP () -> GHC.ApiAnns -> Anns +runAP apf ga = Map.fromListWith combineAnns . snd . runWriter + . flip execStateT (defaultAPState ga) $ apf - 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) +-- `debug` ("runAP:cs=" ++ showGhc cs) -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 +flattenedComments :: GHC.ApiAnns -> [Comment] +flattenedComments (_,cm) = map tokComment . GHC.sortLocated . concat $ Map.elems cm -- ------------------------------------- --- |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)) +getSrcSpanAP = gets (curSrcSpan . ghead "getSrcSpanAP" . apStack) getPriorSrcSpanAP :: AP GHC.SrcSpan -getPriorSrcSpanAP = AP (\l@(_:(ss,_):_) pe e ga -> (ss,l,pe,e,ga,mempty)) +getPriorSrcSpanAP = gets (curSrcSpan . ghead "getPriorSrcSpanAP" . tail . apStack) -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)) +pushSrcSpanAP :: Data a => (GHC.Located a) -> DeltaPos -> AP () +pushSrcSpanAP (GHC.L l a) edp = + let newss = StackItem l edp [] False (annGetConstr a) in + modify (\s -> s { apStack = newss : (apStack s) }) popSrcSpanAP :: AP () -popSrcSpanAP = AP (\(_:ls) pe e ga -> ((),ls,pe,e,ga,mempty)) +popSrcSpanAP = modify (\s -> s { apStack = tail (apStack s) }) --- --------------------------------------------------------------------- +getEntryDP :: AP DeltaPos +getEntryDP = gets (offset . head . apStack) -startGroupingOffsets :: AP () -startGroupingOffsets = do - return () +getUnallocatedComments :: AP [Comment] +getUnallocatedComments = gets apComments -stopGroupingOffsets :: AP () -stopGroupingOffsets = do - return () +putUnallocatedComments :: [Comment] -> AP () +putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) -amendDeltaForGrouping :: DeltaPos -> AP DeltaPos -amendDeltaForGrouping p = do - return p +-- --------------------------------------------------------------------- adjustDeltaForOffsetM :: DeltaPos -> AP DeltaPos adjustDeltaForOffsetM dp = do @@ -166,101 +183,111 @@ 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')) +adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line +adjustDeltaForOffset colOffset (DP (l,c)) = DP (l,c - colOffset) -- --------------------------------------------------------------------- -- | Get the current column offset -getCurrentColOffset :: AP Int -getCurrentColOffset = do - ss <- getSrcSpanAP - return (srcSpanStartColumn ss) -- AZ: - 1? +getCurrentColOffset :: AP ColOffset +getCurrentColOffset = srcSpanStartColumn <$> getSrcSpanAP -- |Get the difference between the current and the previous -- colOffsets, if they are on the same line -getCurrentDP :: AP DeltaPos +getCurrentDP :: AP (ColOffset,LineChanged) getCurrentDP = do + -- Note: the current col offsets are not needed here, any + -- indentation should be fully nested in an AST element ss <- getSrcSpanAP ps <- getPriorSrcSpanAP - 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)) - + layoutOn <- getLayoutOn + {- + let r = if srcSpanStartLine ss == srcSpanStartLine ps + then (srcSpanStartColumn ss - srcSpanStartColumn ps,LineSame) + else (srcSpanStartColumn ss, LineChanged) + -} + let colOffset = if srcSpanStartLine ss == srcSpanStartLine ps + then srcSpanStartColumn ss - srcSpanStartColumn ps + else srcSpanStartColumn ss + let r = case (layoutOn, srcSpanStartLine ss == srcSpanStartLine ps) of + (True, True) -> (colOffset, LayoutLineSame) + (True, False) -> (colOffset, LayoutLineChanged) + (False, True) -> (colOffset, LineSame) + (False,False) -> (colOffset, LineChanged) + return r + `debug` ("getCurrentDP:layoutOn=" ++ show layoutOn) -- --------------------------------------------------------------------- -- |Note: assumes the prior end SrcSpan stack is nonempty getPriorEnd :: AP GHC.SrcSpan -getPriorEnd = AP (\l pe e ga -> (pe,l,pe,e,ga,mempty)) +getPriorEnd = gets priorEndPosition setPriorEnd :: GHC.SrcSpan -> AP () -setPriorEnd pe = AP (\ls _ e ga -> ((),ls,pe,e,ga,mempty)) +setPriorEnd pe = modify (\s -> s { priorEndPosition = pe }) -- ------------------------------------- -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)) - +getAnnotationAP :: GHC.AnnKeywordId -> AP [GHC.SrcSpan] +getAnnotationAP an = do + ga <- gets apAnns + ss <- getSrcSpanAP + return $ GHC.getAnnotation ga ss an getAndRemoveAnnotationAP :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP [GHC.SrcSpan] -getAndRemoveAnnotationAP sp an = AP (\l pe e ga -> - let - (r,ga') = GHC.getAndRemoveAnnotation ga sp an - in (r, l,pe,e,ga',mempty)) +getAndRemoveAnnotationAP sp an = do + ga <- gets apAnns + let (r,ga') = GHC.getAndRemoveAnnotation ga sp an + r <$ modify (\s -> s { apAnns = ga' }) --- ------------------------------------- --- |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)) - ) +tokComment :: GHC.Located GHC.AnnotationComment -> Comment +tokComment t@(GHC.L lt _) = Comment (ss2span lt) (ghcCommentText t) -- ------------------------------------- -- |Add some annotation to the currently active SrcSpan addAnnotationsAP :: Annotation -> AP () -addAnnotationsAP ann = AP (\l pe e ga -> - ( (),l,pe,e,ga, - ([((ghead "addAnnotationsAP" l),ann)],[]))) +addAnnotationsAP ann = do + l <- gets apStack + tell [((getAnnKey $ ghead "addAnnotationsAP" l),ann)] +getAnnKey :: StackItem -> AnnKey +getAnnKey StackItem {curSrcSpan, annConName} = AnnKey curSrcSpan annConName + -- ------------------------------------- addAnnDeltaPos :: (GHC.SrcSpan,KeywordId) -> DeltaPos -> AP () -addAnnDeltaPos (s,kw) dp = AP (\l pe e ga -> ( (), - l,pe,e,ga, - ([], - [ ((s,kw),[dp]) ]) )) +addAnnDeltaPos (_s,kw) dp = do + (st:sts) <- gets apStack + modify (\s -> s { apStack = (manip st) : sts }) + where + manip s = s { annOffsets = (kw, dp) : (annOffsets s) } -- ------------------------------------- +getLayoutOn :: AP Bool +getLayoutOn = gets (curLayoutOn . ghead "getSrcSpanAP" . apStack) + +setLayoutOn :: Bool -> AP () +setLayoutOn layoutOn = do + (st:sts) <- gets apStack + modify (\s -> s { apStack = (manip st) : sts }) + where + manip s = s { curLayoutOn = layoutOn } + +-- ------------------------------------- + +getKds :: AP [(KeywordId,DeltaPos)] +getKds = gets (reverse . annOffsets . head . apStack) + +-- ------------------------------------- + setFunIsInfix :: Bool -> AP () -setFunIsInfix e = AP (\l pe _ ga -> ((),l,pe,e,ga,mempty)) +setFunIsInfix e = modify (\s -> s {e_is_infix = e}) getFunIsInfix :: AP Bool -getFunIsInfix = AP (\l pe e ga -> (e,l,pe,e,ga,mempty)) +getFunIsInfix = gets e_is_infix -- ------------------------------------- @@ -268,16 +295,20 @@ enterAST :: Data a => GHC.Located a -> AP () enterAST lss = do return () `debug` ("enterAST entered for " ++ show (ss2span $ GHC.getLoc lss)) - pushSrcSpanAP lss + -- return () `debug` ("enterAST:currentColOffset=" ++ show (DP (0,srcSpanStartColumn $ GHC.getLoc lss))) + -- Calculate offset required to get to the start of the SrcSPan + pe <- getPriorEnd + let ss = (GHC.getLoc lss) + let edp = deltaFromSrcSpans pe ss + edp' <- adjustDeltaForOffsetM edp + -- need to save edp', and put it in Annotation + + pushSrcSpanAP lss edp' + return () --- | Pop up the SrcSpan stack, capture the annotations, 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. +-- | Pop up the SrcSpan stack, capture the annotations leaveAST :: AP () leaveAST = do -- Automatically add any trailing comma or semi @@ -287,17 +318,13 @@ 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)) + (dp,nl) <- getCurrentDP + edp <- getEntryDP + kds <- getKds + addAnnotationsAP (Ann edp nl (srcSpanStartColumn ss) dp kds) + `debug` ("leaveAST:(ss,edp,dp,kds)=" ++ show (showGhc ss,edp,dp,kds,dp)) popSrcSpanAP - return () `debug` ("leaveAST:(ss,dp,priorEnd)=" ++ show (ss2span ss,dp,ss2span priorEnd)) + return () -- `debug` ("leaveAST:(ss,dp,priorEnd)=" ++ show (ss2span ss,dp,ss2span priorEnd)) -- --------------------------------------------------------------------- @@ -306,12 +333,14 @@ -- |First move to the given location, then call exactP annotatePC :: (AnnotateP ast) => GHC.Located ast -> AP () -annotatePC a@(GHC.L l ast) = do +annotatePC a = withLocated a annotateP + +withLocated :: Data a => GHC.Located a -> (GHC.SrcSpan -> a -> AP ()) -> AP () +withLocated a@(GHC.L l ast) action = do enterAST a `debug` ("annotatePC:entering " ++ showGhc l) - annotateP l ast + action l ast leaveAST `debug` ("annotatePC:leaving " ++ showGhc (l)) - annotateMaybe :: (AnnotateP ast) => Maybe (GHC.Located ast) -> AP () annotateMaybe Nothing = return () annotateMaybe (Just ast) = annotatePC ast @@ -319,21 +348,33 @@ annotateList :: (AnnotateP ast) => [GHC.Located ast] -> AP () annotateList xs = mapM_ annotatePC xs +-- | Flag the item to be annotated as requiring layout. +annotateWithLayout :: AnnotateP ast => GHC.Located ast -> AP () +annotateWithLayout a = do + withLocated a (\l ast -> annotateP l ast >> setLayoutOn True) + +annotateListWithLayout :: AnnotateP [GHC.Located ast] => GHC.SrcSpan -> [GHC.Located ast] -> AP () +annotateListWithLayout l ls = do + let ss = getListSrcSpan ls + addAnnDeltaPos (l,AnnList ss) (DP (0,0)) + annotateWithLayout (GHC.L ss ls) + -- --------------------------------------------------------------------- isGoodDelta :: DeltaPos -> Bool isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0 -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) +-- --------------------------------------------------------------------- +-- |Split the ordered list of comments into ones that occur prior to +-- the given SrcSpan and the rest +allocatePriorComments :: [Comment] -> GHC.SrcSpan -> ([Comment],[Comment]) +allocatePriorComments cs ss = partition isPrior cs + where + (start,_) = ss2span ss + isPrior (Comment s _) = (fst s) < start + `debug` ("allocatePriorComments:(s,ss,cond)=" ++ showGhc (s,ss,(fst s) < start)) + -- --------------------------------------------------------------------- addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> AP () @@ -345,29 +386,45 @@ 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.AnnSemi, False) -> return () + (G GHC.AnnOpen, False) -> return () (G GHC.AnnClose,False) -> return () - `debug` ("addDeltaAnnotationWorker::bad delta:(ss,ma,p,ann)=" ++ show (ss2span ss,ss2span pa,p,ann)) _ -> do + cs <- getUnallocatedComments + let (allocated,cs') = allocatePriorComments cs pa + putUnallocatedComments cs' + return () `debug`("addAnnotationWorker:(ss,pa,allocated,cs)=" ++ showGhc (ss,pa,allocated,cs)) + mapM_ addDeltaComment allocated p' <- adjustDeltaForOffsetM p addAnnDeltaPos (ss,ann) p' setPriorEnd pa - `debug` ("addDeltaAnnotationWorker:(ss,pe,pa,p,ann)=" ++ show (ss2span ss,ss2span pe,ss2span pa,p,ann)) + -- `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)) + -- `debug` ("addDeltaAnnotationWorker::point span:(ss,ma,ann)=" ++ show (ss2span pa,ann)) +-- --------------------------------------------------------------------- +addDeltaComment :: Comment -> AP () +addDeltaComment (Comment paspan str) = do + let pa = span2ss paspan + pe <- getPriorEnd + ss <- getSrcSpanAP + let p = deltaFromSrcSpans pe pa + p' <- adjustDeltaForOffsetM p + setPriorEnd pa + let e = ss2deltaP (ss2posEnd pe) (snd paspan) + e' <- adjustDeltaForOffsetM e + addAnnDeltaPos (ss,AnnComment (DComment (p',e') str)) p' + +-- --------------------------------------------------------------------- + -- | Look up and add a Delta annotation at the current position, and -- advance the position to the end of the annotation addDeltaAnnotation :: GHC.AnnKeywordId -> AP () addDeltaAnnotation ann = do ss <- getSrcSpanAP - ma <- getAnnotationAP ss ann + ma <- getAnnotationAP ann case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show ann) [pa] -> addAnnotationWorker (G ann) pa @@ -379,7 +436,7 @@ addDeltaAnnotationAfter :: GHC.AnnKeywordId -> AP () addDeltaAnnotationAfter ann = do ss <- getSrcSpanAP - ma <- getAnnotationAP ss ann + ma <- getAnnotationAP ann let ma' = filter (\s -> not (GHC.isSubspanOf s ss)) ma case ma' of [] -> return () `debug` ("addDeltaAnnotation empty ma") @@ -390,22 +447,19 @@ -- 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 + ma <- getAnnotationAP ann case (drop off ma) of [] -> return () - `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma)) + -- `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 + ma <- getAnnotationAP ann let do_one ap' = addAnnotationWorker (G ann) ap' - `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) + -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) mapM_ do_one (sort ma) -- | Look up and add possibly multiple Delta annotations enclosed by @@ -414,9 +468,9 @@ addDeltaAnnotationsInside :: GHC.AnnKeywordId -> AP () addDeltaAnnotationsInside ann = do ss <- getSrcSpanAP - ma <- getAnnotationAP ss ann + ma <- getAnnotationAP ann let do_one ap' = addAnnotationWorker (G ann) ap' - `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) + -- `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 @@ -428,36 +482,35 @@ -- ma <- getAnnotationAP ss gann ma <- getAndRemoveAnnotationAP ss gann let do_one ap' = addAnnotationWorker ann ap' - `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) + -- `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 + addAnnotationWorker (G ann) s + addEofAnnotation :: AP () addEofAnnotation = do pe <- getPriorEnd ss <- getSrcSpanAP - ma <- getAnnotationAP GHC.noSrcSpan GHC.AnnEofPos + pushSrcSpanAP (GHC.noLoc ()) (DP (0,0)) + ma <- getAnnotationAP GHC.AnnEofPos + popSrcSpanAP case ma of [] -> return () [pa] -> do + cs <- getUnallocatedComments + mapM_ addDeltaComment cs let DP (r,c) = deltaFromSrcSpans pe pa addAnnDeltaPos (ss,G GHC.AnnEofPos) (DP (r, c - 1)) setPriorEnd pa countAnnsAP :: GHC.AnnKeywordId -> AP Int countAnnsAP ann = do - ss <- getSrcSpanAP - ma <- getAnnotationAP ss ann + ma <- getAnnotationAP ann return (length ma) -- --------------------------------------------------------------------- @@ -478,7 +531,7 @@ annotateLHsModule :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> Anns annotateLHsModule modu ghcAnns - = runAP (addFinalComments >> annotatePC modu) ghcAnns + = runAP (pushSrcSpanAP (GHC.L GHC.noSrcSpan ()) (DP (0,0)) >> annotatePC modu) ghcAnns -- --------------------------------------------------------------------- @@ -574,16 +627,16 @@ annotateP l n = do case rdrName2String n of "[]" -> do - addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG - addDeltaAnnotation GHC.AnnCloseS -- ']' BUG + addDeltaAnnotation GHC.AnnOpenS -- '[' + addDeltaAnnotation GHC.AnnCloseS -- ']' "()" -> do - addDeltaAnnotation GHC.AnnOpenP -- '(' + addDeltaAnnotation GHC.AnnOpenP -- '(' addDeltaAnnotation GHC.AnnCloseP -- ')' "(##)" -> do - addDeltaAnnotation GHC.AnnOpen -- '(#' + addDeltaAnnotation GHC.AnnOpen -- '(#' addDeltaAnnotation GHC.AnnClose -- '#)' "[::]" -> do - addDeltaAnnotation GHC.AnnOpen -- '[:' + addDeltaAnnotation GHC.AnnOpen -- '[:' addDeltaAnnotation GHC.AnnClose -- ':]' _ -> do addDeltaAnnotation GHC.AnnType @@ -898,6 +951,7 @@ addDeltaAnnotation GHC.AnnOpenC -- '{' addDeltaAnnotationsInside GHC.AnnSemi + -- AZ:Need to turn this into a located list annotation. -- must merge all the rest applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs @@ -945,13 +999,15 @@ addDeltaAnnotation GHC.AnnEqual mapM_ annotatePC grhs addDeltaAnnotation GHC.AnnWhere - annotateHsLocalBinds lb - annotateP _ (GHC.VarBind _n rhse _) = do + -- TODO: Store the following SrcSpan in an AnnList instance for exactPC + annotatePC (GHC.L (getLocalBindsSrcSpan lb) lb) + + annotateP _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker annotatePC rhse - annotateP _ (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + annotateP l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do addDeltaAnnotation GHC.AnnPattern annotatePC ln case args of @@ -966,7 +1022,7 @@ case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> annotateMatchGroup mg + GHC.ExplicitBidirectional mg -> annotateMatchGroup l mg addDeltaAnnotation GHC.AnnWhere addDeltaAnnotation GHC.AnnOpenC -- '{' @@ -1025,7 +1081,8 @@ addDeltaAnnotation GHC.AnnWhere addDeltaAnnotation GHC.AnnOpenC -- '{' addDeltaAnnotationsInside GHC.AnnSemi - annotateHsLocalBinds lb + -- annotateHsLocalBinds lb + annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) addDeltaAnnotation GHC.AnnCloseC -- '}' -- --------------------------------------------------------------------- @@ -1450,10 +1507,12 @@ annotatePC body annotateP _ (GHC.LetStmt lb) = do + -- return () `debug` ("annotateP.LetStmt entered") addDeltaAnnotation GHC.AnnLet addDeltaAnnotation GHC.AnnOpenC -- '{' - annotateHsLocalBinds lb + annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) addDeltaAnnotation GHC.AnnCloseC -- '}' + -- return () `debug` ("annotateP.LetStmt done") annotateP _ (GHC.ParStmt pbs _ _) = do mapM_ annotateParStmtBlock pbs @@ -1489,11 +1548,49 @@ annotateParStmtBlock :: (GHC.DataId name,GHC.OutputableBndr name, AnnotateP name) => GHC.ParStmtBlock name name -> AP () -annotateParStmtBlock (GHC.ParStmtBlock stmts _ns _) = do +annotateParStmtBlock (GHC.ParStmtBlock stmts _ns _) = mapM_ annotatePC stmts -- --------------------------------------------------------------------- +-- | Local binds need to be indented as a group, and thus need to have a +-- SrcSpan around them so they can be processed via the normal +-- annotatePC / exactPC machinery. +getLocalBindsSrcSpan :: GHC.HsLocalBinds name -> GHC.SrcSpan +getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) + = case spans of + [] -> GHC.noSrcSpan + sss -> GHC.combineSrcSpans (head sss) (last sss) + where + spans = sort (map GHC.getLoc (GHC.bagToList binds) ++ map GHC.getLoc sigs) + +getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsOut {})) + = error "getLocalBindsSrcSpan: only valid after type checking" + +getLocalBindsSrcSpan (GHC.HsIPBinds (GHC.IPBinds binds _)) + = case sort (map GHC.getLoc binds) of + [] -> GHC.noSrcSpan + sss -> GHC.combineSrcSpans (head sss) (last sss) + +getLocalBindsSrcSpan (GHC.EmptyLocalBinds) = GHC.noSrcSpan + +-- --------------------------------------------------------------------- + +-- | Generate a SrcSpan that enclosed the given list +getListSrcSpan :: [GHC.Located a] -> GHC.SrcSpan +getListSrcSpan ls + = case ls of + [] -> GHC.noSrcSpan + sss -> GHC.combineLocs (head sss) (last sss) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) + => AnnotateP (GHC.HsLocalBinds name) where + annotateP _ lb = annotateHsLocalBinds lb + +-- --------------------------------------------------------------------- + annotateHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => (GHC.HsLocalBinds name) -> AP () annotateHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do @@ -1504,19 +1601,26 @@ = error $ "annotateHsLocalBinds: only valid after type checking" annotateHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ annotatePC binds -annotateHsLocalBinds (GHC.EmptyLocalBinds) = return () +annotateHsLocalBinds (GHC.EmptyLocalBinds) = return () -- --------------------------------------------------------------------- annotateMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, AnnotateP body) - => (GHC.MatchGroup name (GHC.Located body)) + => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body)) -> AP () -annotateMatchGroup (GHC.MG matches _ _ _) - = mapM_ annotatePC matches +annotateMatchGroup l (GHC.MG matches _ _ _) + = annotateListWithLayout l matches -- --------------------------------------------------------------------- +instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, + AnnotateP body) + => AnnotateP [GHC.Located (GHC.Match name (GHC.Located body))] where + annotateP _ ls = mapM_ annotatePC ls + +-- --------------------------------------------------------------------- + instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => AnnotateP (GHC.HsExpr name) where annotateP l (GHC.HsVar n) = annotateP l n @@ -1524,11 +1628,11 @@ annotateP l (GHC.HsOverLit _ov) = addDeltaAnnotationExt l GHC.AnnVal annotateP l (GHC.HsLit _) = addDeltaAnnotationExt l GHC.AnnVal - annotateP _ (GHC.HsLam match) = do + annotateP l (GHC.HsLam match) = do addDeltaAnnotation GHC.AnnLam - annotateMatchGroup match + annotateMatchGroup l match - annotateP _ (GHC.HsLamCase _ match) = annotateMatchGroup match + annotateP l (GHC.HsLamCase _ match) = annotateMatchGroup l match annotateP _ (GHC.HsApp e1 e2) = do annotatePC e1 @@ -1563,13 +1667,13 @@ addDeltaAnnotation GHC.AnnCloseP addDeltaAnnotation GHC.AnnClose - annotateP _ (GHC.HsCase e1 matches) = do + annotateP l (GHC.HsCase e1 matches) = do addDeltaAnnotation GHC.AnnCase annotatePC e1 addDeltaAnnotation GHC.AnnOf addDeltaAnnotation GHC.AnnOpenC addDeltaAnnotationsInside GHC.AnnSemi - annotateMatchGroup matches + annotateMatchGroup l matches addDeltaAnnotation GHC.AnnCloseC annotateP _ (GHC.HsIf _ e1 e2 e3) = do @@ -1587,17 +1691,16 @@ mapM_ annotatePC rhs annotateP _ (GHC.HsLet binds e) = do + setLayoutOn True -- Make sure the 'in' gets indented too addDeltaAnnotation GHC.AnnLet - startGroupingOffsets addDeltaAnnotation GHC.AnnOpenC addDeltaAnnotationsInside GHC.AnnSemi - annotateHsLocalBinds binds + annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) addDeltaAnnotation GHC.AnnCloseC - stopGroupingOffsets addDeltaAnnotation GHC.AnnIn annotatePC e - annotateP _ (GHC.HsDo cts es _) = do + annotateP l (GHC.HsDo cts es _) = do addDeltaAnnotation GHC.AnnDo addDeltaAnnotation GHC.AnnOpen addDeltaAnnotation GHC.AnnOpenS @@ -1609,7 +1712,7 @@ addDeltaAnnotation GHC.AnnVbar mapM_ annotatePC (init es) else do - mapM_ annotatePC es + annotateListWithLayout l es addDeltaAnnotation GHC.AnnCloseS addDeltaAnnotation GHC.AnnCloseC addDeltaAnnotation GHC.AnnClose @@ -1811,7 +1914,15 @@ -- --------------------------------------------------------------------- +-- |Used for declarations that need to be aligned together, e.g. in a +-- do or let .. in statement/expr instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) + => AnnotateP ([GHC.ExprLStmt name]) where + annotateP _ ls = mapM_ annotatePC ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => AnnotateP (GHC.HsTupArg name) where annotateP _ (GHC.Present e) = do annotatePC e @@ -1847,21 +1958,21 @@ annotatePC e1 annotatePC e2 - annotateP _ (GHC.HsCmdLam match) = do + annotateP l (GHC.HsCmdLam match) = do addDeltaAnnotation GHC.AnnLam - annotateMatchGroup match + annotateMatchGroup l match annotateP _ (GHC.HsCmdPar e) = do addDeltaAnnotation GHC.AnnOpenP -- '(' annotatePC e addDeltaAnnotation GHC.AnnCloseP -- ')' - annotateP _ (GHC.HsCmdCase e1 matches) = do + annotateP l (GHC.HsCmdCase e1 matches) = do addDeltaAnnotation GHC.AnnCase annotatePC e1 addDeltaAnnotation GHC.AnnOf addDeltaAnnotation GHC.AnnOpenC - annotateMatchGroup matches + annotateMatchGroup l matches addDeltaAnnotation GHC.AnnCloseC annotateP _ (GHC.HsCmdIf _ e1 e2 e3) = do @@ -1877,15 +1988,16 @@ annotateP _ (GHC.HsCmdLet binds e) = do addDeltaAnnotation GHC.AnnLet addDeltaAnnotation GHC.AnnOpenC - annotateHsLocalBinds binds + annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) addDeltaAnnotation GHC.AnnCloseC addDeltaAnnotation GHC.AnnIn annotatePC e - annotateP _ (GHC.HsCmdDo es _) = do + annotateP l (GHC.HsCmdDo es _) = do addDeltaAnnotation GHC.AnnDo addDeltaAnnotation GHC.AnnOpenC - mapM_ annotatePC es + -- mapM_ annotatePC es + annotateListWithLayout l es addDeltaAnnotation GHC.AnnCloseC annotateP _ (GHC.HsCmdCast {}) = error $ "annotateP.HsCmdCast: only valid after type checker" @@ -1894,6 +2006,12 @@ -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) + => AnnotateP [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where + annotateP _ ls = mapM_ annotatePC ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => AnnotateP (GHC.TyClDecl name) where annotateP l (GHC.FamDecl famdecl) = annotateP l famdecl @@ -2025,7 +2143,6 @@ addDeltaAnnotation GHC.AnnDeriving addDeltaAnnotation GHC.AnnOpenP mapM_ annotatePC ts - -- addDeltaAnnotation GHC.AnnUnit -- for empty context addDeltaAnnotation GHC.AnnCloseP addDeltaAnnotation GHC.AnnDarrow @@ -2109,50 +2226,21 @@ -- --------------------------------------------------------------------- --- | 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)) +undeltaComment l con (DComment (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 + r = Comment ((adj dps $ undelta l dps co),(adj dps $ undelta l dpe co)) s co = con dc = - con -- + (coo - con) -- adj makes provision for the possible movement of the -- surrounding context, and so applies the difference between the -- original and current offsets - adj (DP ( 0,dco)) (row,c) = (row,c) - adj (DP (dro,dco)) (row,c) = (row,c + dc) - -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 + adj (DP ( 0,_dco)) (row,c) = (row,c) + adj (DP (_dro,_dco)) (row,c) = (row,c + dc) -- | Create a delta covering the gap between the end of the first -- @SrcSpan@ and the start of the second. @@ -2172,14 +2260,15 @@ else c -- | Apply the delta to the current position, taking into account the --- current column offset -undelta :: Pos -> DeltaPos -> Int -> Pos +-- current column offset if advancing to a new line +undelta :: Pos -> DeltaPos -> ColOffset -> Pos undelta (l,c) (DP (dl,dc)) co = (fl,fc) where fl = l + dl - fc = if dl == 0 then c + dc else co + dc + fc = if dl == 0 then c + dc + else co + dc --- prop_delta :: TODO +-- --------------------------------------------------------------------- ss2pos :: GHC.SrcSpan -> Pos ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss) @@ -2215,6 +2304,14 @@ -- --------------------------------------------------------------------- +span2ss :: Span -> GHC.SrcSpan +span2ss ((sr,sc),(er,ec)) = l + where + filename = (GHC.mkFastString "f") + l = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec) + +-- --------------------------------------------------------------------- + isPointSrcSpan :: GHC.SrcSpan -> Bool isPointSrcSpan ss = s == e where (s,e) = ss2span ss @@ -2237,31 +2334,6 @@ -- --------------------------------------------------------------------- -{- -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 @@ -2292,26 +2364,12 @@ -- |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 -- --------------------------------------------------------------------- @@ -2325,40 +2383,18 @@ -- --------------------------------------------------------------------- --- |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 :: Data a => Anns -> Int -> a -> String showAnnData anns n = - generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan + generic -- `ext1Q` located + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` overLit `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity + `ext2Q` located where generic :: Data a => a -> String generic t = indent n ++ "(" ++ showConstr (toConstr t) ++ space (concat (intersperse " " (gmapQ (showAnnData anns (n+1)) t))) ++ ")" @@ -2377,7 +2413,9 @@ -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String srcSpan :: GHC.SrcSpan -> String srcSpan ss = "{ "++ (showSDoc_ (GHC.hang (GHC.ppr ss) (n+2) - (GHC.ppr (Map.lookup ss anns)))) + -- (GHC.ppr (Map.lookup ss anns) + (GHC.text "") + )) ++"}" var = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String @@ -2397,7 +2435,18 @@ fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String + located :: (Data b,Data loc) => GHC.GenLocated loc b -> String + -- located la = show (getAnnotationEP la anns) + located la@(GHC.L ss a) = indent n ++ "(" + ++ case (cast ss) of + Just (s::GHC.SrcSpan) -> srcSpan s + ++ indent (n + 1) ++ show (getAnnotationEP (GHC.L s a) anns) + Nothing -> "nnnnnnnn" + ++ showAnnData anns (n+1) a + ++ ")" +-- --------------------------------------------------------------------- + showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags @@ -2419,43 +2468,4 @@ 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 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,24 +1,39 @@ -{-# 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 Bag as GHC import qualified DynFlags as GHC +import qualified ErrUtils as GHC import qualified FastString as GHC import qualified GHC as GHC --- import qualified MonadUtils as GHC +import qualified HscTypes as GHC +import qualified Lexer as GHC +import qualified MonadUtils as GHC +import qualified OccName as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC -- import qualified Outputable as GHC +import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB +import Data.IORef +import Control.Exception import Control.Monad import System.Directory import System.FilePath import System.IO +import System.Exit +import qualified Data.Map as Map import Test.HUnit @@ -26,8 +41,13 @@ -- --------------------------------------------------------------------- -main :: IO Counts -main = runTestTT tests +main :: IO () +main = do + cnts <- runTestTT tests + putStrLn $ show cnts + if errors cnts > 0 || failures cnts > 0 + then exitFailure + else return () -- exitSuccess -- tests = TestCase (do r <- manipulateAstTest "examples/LetStmt.hs" "Layout.LetStmt" -- assertBool "test" r ) @@ -110,12 +130,24 @@ , mkTestMod "B.hs" "Main" , mkTestMod "LayoutWhere.hs" "Main" , mkTestMod "LayoutLet.hs" "Main" + , mkTestMod "LayoutIn1.hs" "LayoutIn1" + , mkTestMod "LayoutIn4.hs" "LayoutIn4" , mkTestMod "Deprecation.hs" "Deprecation" , mkTestMod "Infix.hs" "Main" , mkTestMod "BCase.hs" "Main" , mkTestMod "AltsSemis.hs" "Main" - , mkTestMod "LetExprSemi.hs" "LetExprSemi" + , mkTestMod "WhereIn4.hs" "WhereIn4" + , mkTestMod "LocToName.hs" "LocToName" + + , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" + , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" + , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" + , mkTestModChange changeRename1 "Rename1.hs" "Main" + , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" + , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" + , mkTestModChange changeLocToName "LocToName.hs" "LocToName" + ] mkTestMain :: FilePath -> Test @@ -127,6 +159,11 @@ = TestCase (do r <- manipulateAstTest fileName modName assertBool fileName r ) +mkTestModChange :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> Test +mkTestModChange change fileName modName + = TestCase (do r <- manipulateAstTestWithMod change fileName modName + assertBool fileName r ) + mkTestModTH :: FilePath -> String -> Test mkTestModTH fileName modName = TestCase (do r <- manipulateAstTestTH fileName modName @@ -136,14 +173,12 @@ tt :: IO Bool tt = do - - manipulateAstTest "LetStmt.hs" "Layout.LetStmt" +{- manipulateAstTest "LetExpr.hs" "LetExpr" manipulateAstTest "ExprPragmas.hs" "ExprPragmas" manipulateAstTest "ListComprehensions.hs" "Main" manipulateAstTest "MonadComprehensions.hs" "Main" manipulateAstTest "FunDeps.hs" "Main" - manipulateAstTest "ImplicitParams.hs" "Main" manipulateAstTest "RecursiveDo.hs" "Main" manipulateAstTest "TypeFamilies.hs" "Main" manipulateAstTest "MultiParamTypeClasses.hs" "Main" @@ -153,7 +188,6 @@ manipulateAstTest "ForeignDecl.hs" "ForeignDecl" manipulateAstTest "Warning.hs" "Warning" manipulateAstTest "Annotations.hs" "Annotations" - manipulateAstTest "DocDecls.hs" "DocDecls" manipulateAstTestTH "QuasiQuote.hs" "QuasiQuote" manipulateAstTest "Roles.hs" "Roles" manipulateAstTest "Splice.hs" "Splice" @@ -164,12 +198,9 @@ manipulateAstTest "PatSynBind.hs" "Main" manipulateAstTest "HsDo.hs" "HsDo" manipulateAstTest "ForAll.hs" "ForAll" - manipulateAstTest "PArr.hs" "PArr" - manipulateAstTest "ViewPatterns.hs" "Main" manipulateAstTest "BangPatterns.hs" "Main" manipulateAstTest "Associated.hs" "Main" manipulateAstTest "Move1.hs" "Move1" - manipulateAstTest "Rules.hs" "Rules" manipulateAstTest "TypeOperators.hs" "Main" manipulateAstTest "NullaryTypeClasses.hs" "Main" manipulateAstTest "FunctionalDeps.hs" "Main" @@ -184,7 +215,6 @@ manipulateAstTest "StaticPointers.hs" "Main" manipulateAstTest "DataDecl.hs" "Main" manipulateAstTest "Guards.hs" "Main" - manipulateAstTest "RebindableSyntax.hs" "Main" manipulateAstTest "RdrNames.hs" "RdrNames" manipulateAstTest "Vect.hs" "Vect" manipulateAstTest "Tuple.hs" "Main" @@ -203,7 +233,6 @@ manipulateAstTest "Utils2.hs" "Utils2" manipulateAstTest "EmptyMostlyInst.hs" "EmptyMostlyInst" manipulateAstTest "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis" - manipulateAstTest "Dead1.hs" "Dead1" manipulateAstTest "EmptyMostly.hs" "EmptyMostly" manipulateAstTest "FromUtils.hs" "Main" manipulateAstTest "DocDecls.hs" "DocDecls" @@ -211,21 +240,110 @@ -- manipulateAstTest "Unicode.hs" "Main" manipulateAstTest "B.hs" "Main" manipulateAstTest "LayoutWhere.hs" "Main" - manipulateAstTest "LayoutLet.hs" "Main" manipulateAstTest "Deprecation.hs" "Deprecation" manipulateAstTest "Infix.hs" "Main" manipulateAstTest "BCase.hs" "Main" + manipulateAstTest "LetExprSemi.hs" "LetExprSemi" + manipulateAstTest "LetExpr2.hs" "Main" + manipulateAstTest "LetStmt.hs" "Layout.LetStmt" + manipulateAstTest "LayoutLet.hs" "Main" + manipulateAstTest "ImplicitParams.hs" "Main" + manipulateAstTest "RebindableSyntax.hs" "Main" + manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" + manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5" + manipulateAstTest "EmptyMostly2.hs" "EmptyMostly2" + manipulateAstTest "WhereIn4.hs" "WhereIn4" manipulateAstTest "AltsSemis.hs" "Main" + manipulateAstTest "PArr.hs" "PArr" + manipulateAstTest "Dead1.hs" "Dead1" + manipulateAstTest "DocDecls.hs" "DocDecls" + manipulateAstTest "ViewPatterns.hs" "Main" + manipulateAstTest "LayoutLet2.hs" "LayoutLet2" + manipulateAstTest "FooExpected.hs" "Main" + manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" + manipulateAstTest "LayoutIn1.hs" "LayoutIn1" + manipulateAstTestWithMod changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" + manipulateAstTest "LocToName.hs" "LocToName" + -} + -- manipulateAstTestWithMod changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" + manipulateAstTestWithMod changeLocToName "LocToName.hs" "LocToName" + -- manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" + -- manipulateAstTestWithMod changeRename1 "Rename1.hs" "Main" + -- manipulateAstTest "Rename1.hs" "Main" + -- manipulateAstTest "Rules.hs" "Rules" - manipulateAstTest "LetExprSemi.hs" "LetExprSemi" {- + manipulateAstTest "ParensAroundContext.hs" "ParensAroundContext" + manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4" manipulateAstTest "Cpp.hs" "Main" manipulateAstTest "Lhs.lhs" "Main" - manipulateAstTest "ParensAroundContext.hs" "ParensAroundContext" - manipulateAstTest "EmptyMostly2.hs" "EmptyMostly2" manipulateAstTest "Foo.hs" "Main" -} +-- --------------------------------------------------------------------- + +changeLayoutLet2 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutLet2 parsed = rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed + +changeLocToName :: GHC.ParsedSource -> GHC.ParsedSource +changeLocToName parsed = rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed + +changeLayoutIn4 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutIn4 parsed = rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed + +changeLayoutIn1 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutIn1 parsed = rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed + +changeRename1 :: GHC.ParsedSource -> GHC.ParsedSource +changeRename1 parsed = rename "bar2" [((3,1),(3,4))] parsed + +changeLayoutLet3 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutLet3 parsed = rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed + +changeLayoutLet5 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutLet5 parsed = rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed + +rename :: (SYB.Data a) => String -> [Span] -> a -> a +rename newNameStr spans a + = SYB.everywhere ( SYB.mkT replaceRdr + `SYB.extT` replaceHsVar + `SYB.extT` replacePat + ) a + where + newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr) + + cond :: GHC.SrcSpan -> Bool + cond ln = any (\ss -> ss2span ln == ss) spans + + replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName + replaceRdr (GHC.L ln _) + | cond ln = GHC.L ln newName + replaceRdr x = x + + replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName + replaceHsVar (GHC.L ln (GHC.HsVar _)) + | cond ln = GHC.L ln (GHC.HsVar newName) + replaceHsVar x = x + + replacePat (GHC.L ln (GHC.VarPat _)) + | cond ln = GHC.L ln (GHC.VarPat newName) + replacePat x = x + + + +-- --------------------------------------------------------------------- + +changeWhereIn4 :: GHC.ParsedSource -> GHC.ParsedSource +changeWhereIn4 parsed + = SYB.everywhere (SYB.mkT replace) parsed + where + replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName + replace (GHC.L ln _n) + | ss2span ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) + replace x = x + +-- --------------------------------------------------------------------- + -- | Where all the tests are to be found examplesDir :: FilePath examplesDir = "tests" "examples" @@ -233,19 +351,25 @@ examplesDir2 :: FilePath examplesDir2 = "examples" +manipulateAstTestWithMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO Bool +manipulateAstTestWithMod change file modname = manipulateAstTest' (Just change) False file modname + manipulateAstTest :: FilePath -> String -> IO Bool -manipulateAstTest file modname = manipulateAstTest' False file modname +manipulateAstTest file modname = manipulateAstTest' Nothing False file modname manipulateAstTestTH :: FilePath -> String -> IO Bool -manipulateAstTestTH file modname = manipulateAstTest' True file modname +manipulateAstTestTH file modname = manipulateAstTest' Nothing True file modname -manipulateAstTest' :: Bool -> FilePath -> String -> IO Bool -manipulateAstTest' useTH file' modname = do +manipulateAstTest' :: Maybe (GHC.ParsedSource -> GHC.ParsedSource) -> Bool -> FilePath -> String -> IO Bool +manipulateAstTest' mchange useTH file' modname = do let testpath = "./tests/examples/" - file = testpath file' - out = file <.> "out" + file = testpath file' + out = file <.> "out" + expected = file <.> "expected" - contents <- readUTF8File file + contents <- case mchange of + Nothing -> readUTF8File file + Just _ -> readUTF8File expected (ghcAnns,t) <- parsedFileGhc file modname useTH let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t @@ -256,17 +380,23 @@ ann = annotateAST parsed ghcAnns `debug` ("ghcAnns:" ++ showGhc ghcAnns) - printed = exactPrintAnnotation parsed [] ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann)) + parsed' = case mchange of + Nothing -> parsed + Just change -> change parsed + printed = exactPrintAnnotation parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann)) result = if printed == contents then "Match\n" else printed ++ "\n==============\n" ++ "lengths:" ++ show (length printed,length contents) ++ "\n" ++ parsedAST - -- putStrLn $ "Test:parsed=" ++ parsedAST + ++ "\n========================\n" + ++ showAnnData ann 0 parsed' writeFile out $ result - -- putStrLn $ "Test:ann organised:" ++ showGhc (organiseAnns ann) - -- putStrLn $ "Test:showdata:" ++ showAnnData (organiseAnns ann) 0 parsed + -- putStrLn $ "Test:parsed=" ++ parsedAST + -- putStrLn $ "Test:ann :" ++ showGhc ann + -- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed + -- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed' return ("Match\n" == result) @@ -278,18 +408,11 @@ 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/"] } + let dflags'' = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/", + "./src/","../src/"] } tgt = if useTH then GHC.HscInterpreted else GHC.HscNothing -- allows FFI @@ -323,12 +446,17 @@ modSum <- GHC.getModSummary $ GHC.mkModuleName modname -- GHC.liftIO $ putStrLn $ "got modSum" -- let modSum = head g +{- + (sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum) + strSrcBuf <- getPreprocessedSrc sourceFile + GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n" +-} 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" + -- GHC.liftIO $ putStrLn $ "toks" ++ show toks let anns = GHC.pm_annotations p -- GHC.liftIO $ putStrLn $ "anns" return (anns,t) @@ -352,3 +480,74 @@ 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) +-- --------------------------------------------------------------------- + +-- | The preprocessed files are placed in a temporary directory, with +-- a temporary name, and extension .hscpp. Each of these files has +-- three lines at the top identifying the original origin of the +-- files, which is ignored by the later stages of compilation except +-- to contextualise error messages. +getPreprocessedSrc :: + -- GHC.GhcMonad m => FilePath -> m GHC.StringBuffer + GHC.GhcMonad m => FilePath -> m String +getPreprocessedSrc srcFile = do + df <- GHC.getSessionDynFlags + d <- GHC.liftIO $ getTempDir df + fileList <- GHC.liftIO $ getDirectoryContents d + let suffix = "hscpp" + + let cppFiles = filter (\f -> getSuffix f == suffix) fileList + origNames <- GHC.liftIO $ mapM getOriginalFile $ map (\f -> d f) cppFiles + let tmpFile = ghead "getPreprocessedSrc" $ filter (\(o,_) -> o == srcFile) origNames + -- buf <- GHC.liftIO $ GHC.hGetStringBuffer $ snd tmpFile + -- return buf + GHC.liftIO $ readUTF8File (snd tmpFile) + +-- --------------------------------------------------------------------- + +getSuffix :: FilePath -> String +getSuffix fname = reverse $ fst $ break (== '.') $ reverse fname + +-- | A GHC preprocessed file has the following comments at the top +-- @ +-- # 1 "./test/testdata/BCpp.hs" +-- # 1 "" +-- # 1 "./test/testdata/BCpp.hs" +-- @ +-- This function reads the first line of the file and returns the +-- string in it. +-- NOTE: no error checking, will blow up if it fails +getOriginalFile :: FilePath -> IO (FilePath,FilePath) +getOriginalFile fname = do + fcontents <- readFile fname + let firstLine = ghead "getOriginalFile" $ lines fcontents + let (_,originalFname) = break (== '"') firstLine + return $ (tail $ init $ originalFname,fname) + + +-- --------------------------------------------------------------------- +-- Copied from the GHC source, since not exported + +getModuleSourceAndFlags :: GHC.GhcMonad m => GHC.Module -> m (String, GHC.StringBuffer, GHC.DynFlags) +getModuleSourceAndFlags modu = do + m <- GHC.getModSummary (GHC.moduleName modu) + case GHC.ml_hs_file $ GHC.ms_location m of + Nothing -> + do dflags <- GHC.getDynFlags + GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr modu) + Just sourceFile -> do + source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile + return (sourceFile, source, GHC.ms_hspp_opts m) + + +-- return our temporary directory within tmp_dir, creating one if we +-- don't have one yet +getTempDir :: GHC.DynFlags -> IO FilePath +getTempDir dflags + = do let ref = GHC.dirsToClean dflags + tmp_dir = GHC.tmpDir dflags + mapping <- readIORef ref + case Map.lookup tmp_dir mapping of + Nothing -> error "should already be a tmpDir" + Just d -> return d +