ghc-exactprint 0.1.0.1 → 0.1.1.0
raw patch · 5 files changed
+952/−650 lines, 5 filesdep +stm
Dependencies added: stm
Files
- ghc-exactprint.cabal +19/−14
- src/Language/Haskell/GHC/ExactPrint.hs +240/−193
- src/Language/Haskell/GHC/ExactPrint/Types.hs +94/−53
- src/Language/Haskell/GHC/ExactPrint/Utils.hs +361/−351
- tests/Test.hs +238/−39
ghc-exactprint.cabal view
@@ -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
src/Language/Haskell/GHC/ExactPrint.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -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)++-- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -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
tests/Test.hs view
@@ -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 "<command-line>"+-- # 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+