ghc-exactprint 0.3.1.1 → 0.4.0.0

raw patch · 49 files changed

+1849/−484 lines, 49 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog +18/−1
• ghc-exactprint.cabal +1/−1
• src/Language/Haskell/GHC/ExactPrint.hs +0/−1
• src/Language/Haskell/GHC/ExactPrint/Annotate.hs +21/−12
• src/Language/Haskell/GHC/ExactPrint/Delta.hs +1/−1
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +1/−1
• src/Language/Haskell/GHC/ExactPrint/Print.hs +114/−63
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +583/−339
• src/Language/Haskell/GHC/ExactPrint/Types.hs +40/−4
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +64/−6
• tests/Test.hs +32/−8
• tests/Test/Common.hs +1/−1
• tests/Test/Transform.hs +289/−46
• tests/examples/AddHiding1.hs +7/−0
• tests/examples/AddHiding1.hs.expected +7/−0
• tests/examples/AddHiding2.hs +5/−0
• tests/examples/AddHiding2.hs.expected +5/−0
• tests/examples/AddLocalDecl4.hs +3/−0
• tests/examples/AddLocalDecl4.hs.expected +6/−0
• tests/examples/AddLocalDecl5.hs +8/−0
• tests/examples/AddLocalDecl5.hs.expected +9/−0
• tests/examples/AddLocalDecl6.hs +9/−0
• tests/examples/AddLocalDecl6.hs.expected +11/−0
• tests/examples/Base.hs +26/−0
• tests/examples/CloneDecl1.hs +10/−0
• tests/examples/CloneDecl1.hs.expected +17/−0
• tests/examples/Error.hs +110/−0
• tests/examples/Join.hs +7/−0
• tests/examples/Lambda.hs +2/−0
• tests/examples/NormaliseLayout.hs +5/−0
• tests/examples/NormaliseLayout.hs.expected +1/−0
• tests/examples/Rename2.hs +4/−0
• tests/examples/Rename2.hs.expected +4/−0
• tests/examples/RmDecl3.hs +1/−0
• tests/examples/RmDecl3.hs.expected +1/−0
• tests/examples/RmDecl4.hs +9/−0
• tests/examples/RmDecl4.hs.expected +10/−0
• tests/examples/RmDecl5.hs +6/−0
• tests/examples/RmDecl5.hs.expected +4/−0
• tests/examples/RmDecl6.hs +11/−0
• tests/examples/RmDecl6.hs.expected +8/−0
• tests/examples/RmDecl7.hs +8/−0
• tests/examples/RmDecl7.hs.expected +6/−0
• tests/examples/RmTypeSig2.hs +7/−0
• tests/examples/RmTypeSig2.hs.expected +6/−0
• tests/examples/SegFault.hs +133/−0
• tests/examples/SegFault2.hs +202/−0
• tests/examples/SimpleDo.hs +4/−0
• tests/examples/TypeSignature.hs +12/−0

@@ -1,5 +1,22 @@+2015-09-28 v0.4.0.0+	* Rework HasDecls so that there are only instances for which it is+	idempotent. Provide functions for managing an LHsBind which is not+	idempotent, and performing general transformations on an AST+	including FunBinds.+	* Manage LHsDecl instances so that the Annotation always attaches+	to the wrapped item, so that they can be seamlessly used in a top+	level (wrapped) or local (unwrapped) context.+	* Tweak transformations based on HaRe integration.+	* This release supports the HaRe 8.0 release, which finally works+	with GHC 7.10.2+	* Rename `exactPrintWithAnns` to `exactPrint`. This will possibly+	break earlier client libraries, but is a simple rename.+	* Bring in semanticPrintM which allows wrapper functions to be+	provided for the generated output, for use when emitting e.g. HTML+	marked up source.+ 2015-08-13 v0.3.1.1-	* Add missing test files to sdist+	* Add missing test files to sdist, closes #23  2015-08-02 v0.3.1 

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             0.3.1.1+version:             0.4.0.0 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 7.10.2, this                      library provides a means to round trip any code that can

@@ -17,7 +17,6 @@         , module Language.Haskell.GHC.ExactPrint.Transform          -- * Printing-        , exactPrintWithAnns         , exactPrint          ) where

@@ -26,7 +26,8 @@          annotate        , AnnotationF(..)        , Annotated-       , Annotate(..)) where+       , Annotate(..)+       ) where  import Data.Maybe ( fromMaybe ) #if __GLASGOW_HASKELL__ <= 710@@ -190,7 +191,7 @@ -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()-markLocated a = withLocated a markAST+markLocated ast = withLocated ast markAST  withLocated :: Data a             => GHC.Located a@@ -268,7 +269,7 @@     markMany GHC.AnnSemi -- possible leading semis     mapM_ markLocated imps -    mapM_ markLocated decs+    mapM_ (\(GHC.L l ast) -> markAST l ast) decs      mark GHC.AnnCloseC -- Possible '}' @@ -492,13 +493,17 @@    markTrailingSemi  -- ---------------------------------------------------------------------+ instance Annotate GHC.ModuleName where    markAST l mname =     markExternal l GHC.AnnVal (GHC.moduleNameString mname) -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)-  => Annotate (GHC.HsDecl name) where-  markAST l decl = do+-- ---------------------------------------------------------------------++-- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+            => GHC.LHsDecl name -> Annotated ()+markLHsDecl (GHC.L l decl) =     case decl of       GHC.TyClD d       -> markLocated (GHC.L l d)       GHC.InstD d       -> markLocated (GHC.L l d)@@ -518,6 +523,10 @@       GHC.QuasiQuoteD d -> markLocated (GHC.L l d) #endif +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+            => Annotate (GHC.HsDecl name) where+  markAST l d = markLHsDecl (GHC.L l d)+ -- ---------------------------------------------------------------------  instance (Annotate name)@@ -1660,11 +1669,7 @@                       else markWithString GHC.AnnClose "#)"  -  -- We set the layout for HsCase and HsIf even though they need not obey-  -- layout rules as when moving these expressions it's useful that they-  -- maintain "internal integrity", that is to say the subparts remain-  -- indented relative to each other.-  markAST l (GHC.HsCase e1 matches) = setLayoutFlag $ do+  markAST l (GHC.HsCase e1 matches) = do     mark GHC.AnnCase     markLocated e1     mark GHC.AnnOf@@ -1673,6 +1678,10 @@     markMatchGroup l matches     mark GHC.AnnCloseC +  -- We set the layout for HsIf even though it need not obey layout rules as+  -- when moving these expressions it's useful that they maintain "internal+  -- integrity", that is to say the subparts remain indented relative to each+  -- other.   markAST _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do     mark GHC.AnnIf     markLocated e1@@ -1831,7 +1840,7 @@   markAST _ (GHC.HsBracket (GHC.DecBrL ds)) = do     markWithString GHC.AnnOpen "[d|"     mark GHC.AnnOpenC-    mapM_ markLocated ds+    mapM_ (\(GHC.L l d) -> markAST l d) ds     mark GHC.AnnCloseC     markWithString GHC.AnnClose "|]"   -- Introduced after the renamer

@@ -65,7 +65,7 @@ import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated-                                                , annotate,  Annotate(..))+                                                , annotate, Annotate(..))  import qualified GHC import qualified SrcLoc         as GHC

@@ -142,7 +142,7 @@ -- parseModule = parseModuleWithCpp defaultCppOptions -- @ ----- Note: 'GHC.ParsedSource' is a synonym for @Located (HsModule RdrName)@+-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GHC.RdrName') parseModule :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, (GHC.Located (GHC.HsModule GHC.RdrName)))) parseModule = parseModuleWithCpp defaultCppOptions 

@@ -2,6 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}  ----------------------------------------------------------------------------- -- |@@ -13,9 +14,9 @@ ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Print         (-          exactPrintWithAnns--        , exactPrint+        exactPrint+        , semanticPrint+        , semanticPrintM          ) where @@ -24,7 +25,6 @@ import Language.Haskell.GHC.ExactPrint.Annotate   (AnnotationF(..), Annotated, Annotate(..), annotate) import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString, unicodeString)-import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns )  import Control.Monad.RWS import Data.Data (Data)@@ -33,60 +33,86 @@ import Data.Maybe (fromMaybe)  import Control.Monad.Trans.Free-+import Control.Monad.Identity  import qualified GHC  ------------------------------------------------------------------------------ -- Printing of source elements --- | Print an AST exactly as specified by the annotations on the nodes in the tree.--- The output of this function should exactly match the source file.-exactPrint :: Annotate ast => GHC.Located ast -> GHC.ApiAnns -> String-exactPrint ast ghcAnns = exactPrintWithAnns ast relativeAnns-  where-    relativeAnns = relativiseApiAnns ast ghcAnns- -- | Print an AST with a map of potential modified `Anns`. The usual way to--- generate such a map is by calling `relativiseApiAnns`.-exactPrintWithAnns :: Annotate ast+-- generate such a map is by using one of the parsers in+-- "Language.Haskell.GHC.ExactPrint.Parsers".+exactPrint :: Annotate ast                      => GHC.Located ast                      -> Anns                      -> String-exactPrintWithAnns ast an = runEP (annotate ast) an+exactPrint = semanticPrint (\_ b -> b) id id +-- | A more general version of `semanticPrint`.+semanticPrintM :: (Annotate ast, Monoid b, Monad m) =>+              (forall a . Data a => GHC.Located a -> b -> m b) -- ^ How to surround an AST fragment+              -> (String -> m b) -- ^ How to output a token+              -> (String -> m b) -- ^ How to output whitespace+              -> GHC.Located ast+              -> Anns+              -> m b+semanticPrintM astOut tokenOut whiteOut ast as =  runEP astOut tokenOut whiteOut (annotate ast) as ++-- | A more general version of 'exactPrint' which allows the customisation+-- of the output whilst retaining the original source formatting. This is+-- useful for smarter syntax highlighting.+semanticPrint :: (Annotate ast, Monoid b) =>+              (forall a . Data a => GHC.Located a -> b -> b) -- ^ How to surround an AST fragment+              -> (String -> b) -- ^ How to output a token+              -> (String -> b) -- ^ How to output whitespace+              -> GHC.Located ast+              -> Anns+              -> b+semanticPrint a b c d e = runIdentity (semanticPrintM (\ast s -> Identity (a ast s)) (return . b) (return . c) d e)++ ------------------------------------------------------ -- The EP monad and basic combinators -data EPReader = EPReader+data EPReader m a = EPReader             {               epAnn :: !Annotation+            , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a+            , epTokenPrint :: String -> m a+            , epWhitespacePrint :: String -> m a             } -data EPWriter = EPWriter-              { output :: !(Endo String) }+data EPWriter a = EPWriter+              { output :: !a } -instance Monoid EPWriter where+instance Monoid w => Monoid (EPWriter w) where   mempty = EPWriter mempty   (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b)  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?+             , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local statE w mith suitable refactoring?              , epMarkLayout :: Bool              , epLHS :: LayoutStartCol              }  --------------------------------------------------------- -type EP a = RWS EPReader EPWriter EPState a+type EP w m a = RWST (EPReader m w) (EPWriter w) EPState m a -runEP :: Annotated () -> Anns -> String-runEP action ans =-  flip appEndo "" . output . snd-  . (\next -> execRWS next initialEPReader (defaultEPState ans))+++runEP :: (Monad m, Monoid a) =>+      (forall ast . Data ast => GHC.Located ast -> a -> m a)+      -> (String -> m a)+      -> (String -> m a)+      -> Annotated () -> Anns -> m a+runEP astPrint wsPrint tokenPrint action ans =+  fmap (output . snd) .+    (\next -> execRWST next (initialEPReader astPrint tokenPrint wsPrint) (defaultEPState ans))   . printInterpret $ action  -- ---------------------------------------------------------------------@@ -100,18 +126,25 @@              , epMarkLayout = False              } -initialEPReader :: EPReader-initialEPReader  = EPReader+initialEPReader ::+      (forall ast . Data ast => GHC.Located ast -> a -> m a)+      -> (String -> m a)+      -> (String -> m a)+      -> EPReader m a+initialEPReader astPrint tokenPrint wsPrint  = EPReader              {                epAnn = annNone+             , epAstPrint = astPrint+             , epWhitespacePrint = wsPrint+             , epTokenPrint = tokenPrint              }  -- --------------------------------------------------------------------- -printInterpret :: Annotated a -> EP a-printInterpret = iterTM go+printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a+printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m)   where-    go :: AnnotationF (EP a) -> EP a+    go :: (Monad m, Monoid w) => AnnotationF (EP w m a) -> EP w m a     go (MarkEOF next) =       printStringAtMaybeAnn (G GHC.AnnEofPos) "" >> next     go (MarkPrim kwid mstr next) =@@ -147,14 +180,14 @@  ------------------------------------------------------------------------- -storeOriginalSrcSpanPrint :: EP AnnKey+storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey storeOriginalSrcSpanPrint = do   Ann{..} <- asks epAnn   case annCapturedSpan of     Nothing -> error "Missing captured SrcSpan"     Just v  -> return v -printStoredString :: EP ()+printStoredString :: (Monad m, Monoid w) => EP w m () printStoredString = do   kd <- gets epAnnKds @@ -166,7 +199,7 @@     ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) ss     _                    -> return () -withSortKey :: [(GHC.SrcSpan, Annotated ())] -> EP ()+withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m () withSortKey xs = do   Ann{..} <- asks epAnn   let ordered = case annSortKey of@@ -181,12 +214,12 @@  ------------------------------------------------------------------------- -allAnns :: GHC.AnnKeywordId -> EP ()+allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m () allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString (G kwid))  ------------------------------------------------------------------------- -- |First move to the given location, then call exactP-exactPC :: Data ast => GHC.Located ast -> EP a -> EP a+exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a exactPC ast action =     do       return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))@@ -196,38 +229,49 @@                 , annFollowingComments=fcomments                 , annsDP=kds                 } = fromMaybe annNone ma+      EPReader{epAstPrint} <- ask       r <- withContext kds an        (mapM_ (uncurry printQueuedComment) comments        >> advance edp-       >> action+       >> censorM (epAstPrint ast) action        <* mapM_ (uncurry printQueuedComment) fcomments)       return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) -advance :: DeltaPos -> EP ()+censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a+censorM f m = passM (liftM (\x -> (x,f)) m)++passM :: (Monoid w, Monad m) => EP w m (a, w -> m w) -> EP w m a+passM m = RWST $ \r s -> do+      ~((a, f),s', EPWriter w) <- runRWST m r s+      w' <- f w+      return (a, s', EPWriter w')++advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () advance cl = do   p <- getPos   colOffset <- getLayoutOffset   printWhitespace (undelta p cl colOffset) -getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)+getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation) getAndRemoveAnnotation a = gets ((getAnnotationEP a) . epAnns) -markPrim :: KeywordId -> Maybe String -> EP ()+markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () markPrim kwid mstr =   let annString = fromMaybe (keywordToString kwid) mstr   in printStringAtMaybeAnn kwid annString -withContext :: [(KeywordId, DeltaPos)]+withContext :: (Monad m, Monoid w)+            => [(KeywordId, DeltaPos)]             -> Annotation-            -> EP a -> EP a-withContext kds an = withKds kds . withOffset an+            -> EP w m a -> EP w m a+withContext kds an x = withKds kds (withOffset an x)  -- --------------------------------------------------------------------- -- -- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous -- offset ---withOffset :: Annotation -> (EP a -> EP a)+withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) withOffset a =   local (\s -> s { epAnn = a }) @@ -235,7 +279,7 @@ -- --------------------------------------------------------------------- -- -- Necessary as there are destructive gets of Kds across scopes-withKds :: [(KeywordId, DeltaPos)] -> EP a -> EP a+withKds :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> EP w m a -> EP w m a withKds kd action = do   modify (\s -> s { epAnnKds = kd : epAnnKds s })   r <- action@@ -244,7 +288,7 @@  ------------------------------------------------------------------------ -setLayout :: EP () -> EP ()+setLayout :: (Monad m, Monoid w) => EP w m () -> EP w m () setLayout k = do   oldLHS <- gets epLHS   modify (\a -> a { epMarkLayout = True } )@@ -252,27 +296,27 @@                               , epLHS = oldLHS } )   k <* reset -getPos :: EP Pos+getPos :: (Monad m, Monoid w) => EP w m Pos getPos = gets epPos -setPos :: Pos -> EP ()+setPos :: (Monad m, Monoid w) => Pos -> EP w m () setPos l = modify (\s -> s {epPos = l})  -- |Get the current column offset-getLayoutOffset :: EP LayoutStartCol+getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol getLayoutOffset = gets epLHS  -- --------------------------------------------------------------------- -printStringAtMaybeAnn :: KeywordId -> String -> EP ()+printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> String -> EP w m () printStringAtMaybeAnn an str = printStringAtMaybeAnnThen an str (return ()) -printStringAtMaybeAnnAll :: KeywordId -> String -> EP ()+printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> String -> EP w m () printStringAtMaybeAnnAll an str = go   where     go = printStringAtMaybeAnnThen an str go -printStringAtMaybeAnnThen :: KeywordId -> String -> EP () -> EP ()+printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> String -> EP w m () -> EP w m () printStringAtMaybeAnnThen an str next = do   annFinal <- getAnnFinal an   case (annFinal, an) of@@ -295,7 +339,7 @@ -- ---------------------------------------------------------------------  -- |destructive get, hence use an annotation once only-getAnnFinal :: KeywordId -> EP (Maybe ([(Comment, DeltaPos)], DeltaPos))+getAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe ([(Comment, DeltaPos)], DeltaPos)) getAnnFinal kw = do   kd <- gets epAnnKds   case kd of@@ -324,7 +368,7 @@  -- |This should be the final point where things are mode concrete, -- before output. Hence the point where comments can be inserted-printStringAtLsDelta :: [(Comment, DeltaPos)] -> DeltaPos -> String -> EP ()+printStringAtLsDelta :: (Monad m, Monoid w) => [(Comment, DeltaPos)] -> DeltaPos -> String -> EP w m () printStringAtLsDelta cs cl s = do   p <- getPos   colOffset <- getLayoutOffset@@ -340,7 +384,7 @@ isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset))  -- AZ:TODO: harvest the commonality between this and printStringAtLsDelta-printQueuedComment :: Comment -> DeltaPos -> EP ()+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () printQueuedComment Comment{commentContents} dp = do   p <- getPos   colOffset <- getLayoutOffset@@ -354,12 +398,12 @@ -- ---------------------------------------------------------------------  -- |non-destructive get-peekAnnFinal :: KeywordId -> EP (Maybe DeltaPos)+peekAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe DeltaPos) peekAnnFinal kw = do   (r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds)   return (snd <$> r) -countAnnsEP :: KeywordId -> EP Int+countAnnsEP :: (Monad m, Monoid w) => KeywordId -> EP w m Int countAnnsEP an = length <$> peekAnnFinal an  -- ---------------------------------------------------------------------@@ -368,32 +412,39 @@ -- --------------------------------------------------------------------- -- Printing functions -printString :: Bool -> String -> EP ()+printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () printString layout str = do   EPState{epPos = (l,c), epMarkLayout} <- get+  EPReader{epTokenPrint, epWhitespacePrint} <- ask   when (epMarkLayout && layout) (                       modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ))   setPos (l, c + length str)-  tell (mempty {output = Endo $ showString str })+  --+  -- tell (mempty {output = Endo $ showString str }) -newLine :: EP ()+  if not layout && c == 0+    then lift (epWhitespacePrint str) >>= \s -> tell (EPWriter { output = s})+    else lift (epTokenPrint str) >>= \s -> tell (EPWriter { output = s})+++newLine :: (Monad m, Monoid w) => EP w m () newLine = do     (l,_) <- getPos     printString False "\n"     setPos (l+1,1) -padUntil :: Pos -> EP ()+padUntil :: (Monad m, Monoid w) => Pos -> EP w m () padUntil (l,c) = do     (l1,c1) <- getPos     if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '        | l1 < l             -> newLine >> padUntil (l,c)        | otherwise          -> return () -printWhitespace :: Pos -> EP ()+printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m () printWhitespace = padUntil -printCommentAt :: Pos -> String -> EP ()+printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () printCommentAt p str = printWhitespace p >> printString False str -printStringAt :: Pos -> String -> EP ()+printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () printStringAt p str = printWhitespace p >> printString True str

@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -12,7 +14,7 @@ -- This module is currently under heavy development, and no promises are made -- about API stability. Use with care. ----- We weclome any feedback / contributions on this, as it is the main point of+-- We welcome any feedback / contributions on this, as it is the main point of -- the library. -- -----------------------------------------------------------------------------@@ -20,22 +22,41 @@         (         -- * The Transform Monad           Transform+        , TransformT(..)         , runTransform+        , runTransformFrom+        , runTransformFromT          -- * Transform monad operations         , logTr+        , logDataWithAnnsTr         , getAnnsT, putAnnsT, modifyAnnsT         , uniqueSrcSpanT -        , wrapSigT,wrapDeclT-        , pushDeclAnnT-        , decl2BindT,decl2SigT+        , cloneT          , getEntryDPT+        , setEntryDPT+        , transferEntryDPT+        , setPrecedingLinesDeclT+        , setPrecedingLinesT         , addSimpleAnnT+        , addTrailingCommaT+        , removeTrailingCommaT -        -- ** Managing lists, Transform monad+        -- ** Managing declarations, in Transform monad+        , HasTransform (..)         , HasDecls (..)+        , hasDeclsSybTransform+        , hsDeclsGeneric+        , hsDeclsPatBind, hsDeclsPatBindD+        , replaceDeclsPatBind, replaceDeclsPatBindD+        , modifyDeclsT+        , modifyValD+        -- *** Utility, does not manage layout+        , hsDeclsValBinds, replaceDeclsValbinds++        -- ** Managing lists, Transform monad         , insertAtStart         , insertAtEnd         , insertAfter@@ -53,16 +74,17 @@         -- * Operations         , isUniqueSrcSpan --        -- * Managing decls-        , declFun-         -- * Pure functions         , mergeAnns         , mergeAnnList         , setPrecedingLinesDecl         , setPrecedingLines         , getEntryDP+        , setEntryDP+        , transferEntryDP+        , addTrailingComma+        , wrapSig, wrapDecl+        , decl2Sig, decl2Bind          ) where @@ -79,9 +101,16 @@ import qualified Data.Generics as SYB  import Data.Data+import Data.List+import Data.Maybe  import qualified Data.Map as Map +import Data.Functor.Identity+-- import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Writer+ -- import Debug.Trace  ------------------------------------------------------------------------------@@ -89,29 +118,57 @@  -- | Monad type for updating the AST and managing the annotations at the same -- time. The W state is used to generate logging information if required.-type Transform a = RWS () [String] (Anns,Int) a+type Transform = TransformT Identity +-- |Monad transformer version of 'Transform' monad+newtype TransformT m a = TransformT { runTransformT :: RWST () [String] (Anns,Int) m a }+                deriving (Monad,Applicative,Functor+                         ,MonadReader ()+                         ,MonadWriter [String]+                         ,MonadState (Anns,Int)+                         -- ,MonadTrans+                         )+++ -- | Run a transformation in the 'Transform' monad, returning the updated -- annotations and any logging generated via 'logTr' runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])-runTransform ans f = runRWS f () (ans,0)+runTransform ans f = runTransformFrom 0 ans f +-- | Run a transformation in the 'Transform' monad, returning the updated+-- annotations and any logging generated via 'logTr', allocating any new+-- SrcSpans from the provided initial value.+runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])+runTransformFrom seed ans f = runRWS (runTransformT f) () (ans,seed)++-- |Run a monad transformer stack for the 'TransformT' monad transformer+runTransformFromT :: (Monad m) => Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])+runTransformFromT seed ans f = runRWST (runTransformT f) () (ans,seed)+ -- |Log a string to the output of the Monad-logTr :: String -> Transform ()+logTr :: (Monad m) => String -> TransformT m () logTr str = tell [str] +-- |Log a representation of the given AST with annotations to the output of the+-- Monad+logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m ()+logDataWithAnnsTr str ast = do+  anns <- getAnnsT+  logTr $ str ++ showAnnData anns 0 ast+ -- |Access the 'Anns' being modified in this transformation-getAnnsT :: Transform Anns+getAnnsT :: (Monad m) => TransformT m Anns getAnnsT = gets fst  -- |Replace the 'Anns' after any changes-putAnnsT :: Anns -> Transform ()+putAnnsT :: (Monad m) => Anns -> TransformT m () putAnnsT ans = do   (_,col) <- get   put (ans,col)  -- |Change the stored 'Anns'-modifyAnnsT :: (Anns -> Anns) -> Transform ()+modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m () modifyAnnsT f = do   ans <- getAnnsT   putAnnsT (f ans)@@ -133,15 +190,24 @@ isUniqueSrcSpan ss = srcSpanStartLine ss == -1  -- ----------------------------------------------------------------------{---- TODO: I suspect this may be needed in future.- -- |Make a copy of an AST element, replacing the existing SrcSpans with new -- ones, and duplicating the matching annotations.-cloneT :: GHC.Located a -> Transform (GHC.Located a)-cloneT _ast = do-  error "Transform.cloneT undefined"--}+cloneT :: (Data a,Typeable a) => a -> Transform (a, [(GHC.SrcSpan, GHC.SrcSpan)])+cloneT ast = do+  runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast+  where+    replaceLocated :: forall loc a. (Typeable loc,Typeable a, Data a)+                    => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] Transform (GHC.GenLocated loc a)+    replaceLocated (GHC.L l t) = do+      case cast l :: Maybe GHC.SrcSpan of+        Just ss -> do+          newSpan <- lift uniqueSrcSpanT+          lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) anns of+                                  Nothing -> anns+                                  Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns)+          tell [(ss, newSpan)]+          return $ fromJust . cast  $ GHC.L newSpan t+        Nothing -> return (GHC.L l t)  -- --------------------------------------------------------------------- @@ -178,113 +244,15 @@  -- --------------------------------------------------------------------- --- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl', duplicating the 'GHC.LSig'--- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the--- original annotation is restored after a 'pushDeclAnnT' call.-wrapSigT :: GHC.LSig GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)-wrapSigT d@(GHC.L _ s) = do-  newSpan <- uniqueSrcSpanT-  let-    f ans = case Map.lookup (mkAnnKey d) ans of-      Nothing -> ans-      Just ann ->-                  Map.insert (mkAnnKey (GHC.L newSpan s)) ann-                $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.SigD s))) ann ans-  modifyAnnsT f-  return (GHC.L newSpan (GHC.SigD s))---- ------------------------------------------------------------------------- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl', duplicating the 'GHC.LHsBind'--- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the--- original annotation is restored after a 'pushDeclAnnT' call.-wrapDeclT :: GHC.LHsBind GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)-wrapDeclT d@(GHC.L _ s) = do-  newSpan <- uniqueSrcSpanT-  let-    f ans = case Map.lookup (mkAnnKey d) ans of-      Nothing -> ans-      Just ann ->-                  Map.insert (mkAnnKey (GHC.L newSpan           s )) ann-                $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.ValD s))) ann ans-  modifyAnnsT f-  return (GHC.L newSpan (GHC.ValD s))---- ------------------------------------------------------------------------- |Copy the top level annotation to a new SrcSpan and the unwrapped decl. This--- is required so that 'decl2Sig' and 'decl2Bind' will produce values that have--- the required annotations.-pushDeclAnnT :: GHC.LHsDecl GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)-pushDeclAnnT ld@(GHC.L l decl) = do-  newSpan <- uniqueSrcSpanT-  let-    blend ann Nothing = ann-    blend ann (Just annd)-      = annd { annEntryDelta        = annEntryDelta ann-             , annPriorComments     = annPriorComments     ann  ++ annPriorComments     annd-             , annFollowingComments = annFollowingComments annd ++ annFollowingComments ann-             }-    duplicateAnn d ans =-      case Map.lookup (mkAnnKey ld) ans of-        Nothing -> error $ "pushDeclAnnT:no key found for:" ++ show (mkAnnKey ld)-        -- Nothing -> Anns ans-        Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d))-                                      (blend ann (Map.lookup (mkAnnKey (GHC.L l d)) ans))-                                      ans-  case decl of-    GHC.TyClD d       -> modifyAnnsT (duplicateAnn d)-    GHC.InstD d       -> modifyAnnsT (duplicateAnn d)-    GHC.DerivD d      -> modifyAnnsT (duplicateAnn d)-    GHC.ValD d        -> modifyAnnsT (duplicateAnn d)-    GHC.SigD d        -> modifyAnnsT (duplicateAnn d)-    GHC.DefD d        -> modifyAnnsT (duplicateAnn d)-    GHC.ForD d        -> modifyAnnsT (duplicateAnn d)-    GHC.WarningD d    -> modifyAnnsT (duplicateAnn d)-    GHC.AnnD d        -> modifyAnnsT (duplicateAnn d)-    GHC.RuleD d       -> modifyAnnsT (duplicateAnn d)-    GHC.VectD d       -> modifyAnnsT (duplicateAnn d)-    GHC.SpliceD d     -> modifyAnnsT (duplicateAnn d)-    GHC.DocD d        -> modifyAnnsT (duplicateAnn d)-    GHC.RoleAnnotD d  -> modifyAnnsT (duplicateAnn d)-#if __GLASGOW_HASKELL__ < 711-    GHC.QuasiQuoteD d -> modifyAnnsT (duplicateAnn d)-#endif-  return (GHC.L newSpan decl)---- ------------------------------------------------------------------------- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LHsBind', transferring the top--- level annotation to a new unique 'GHC.SrcSpan' in the process.-decl2BindT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LHsBind GHC.RdrName]-decl2BindT vd@(GHC.L _ (GHC.ValD d)) = do-  newSpan <- uniqueSrcSpanT-  logTr $ "decl2BindT:newSpan=" ++ showGhc newSpan-  let-    duplicateAnn ans =-      case Map.lookup (mkAnnKey vd) ans of-        Nothing -> ans-        Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d)) ann ans-  modifyAnnsT duplicateAnn-  return [GHC.L newSpan d]-decl2BindT _ = return []+-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'+wrapSig :: GHC.LSig GHC.RdrName -> GHC.LHsDecl GHC.RdrName+wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)  -- --------------------------------------------------------------------- --- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LSig', transferring the top--- level annotation to a new unique 'GHC.SrcSpan' in the process.-decl2SigT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LSig GHC.RdrName]-decl2SigT vs@(GHC.L _ (GHC.SigD s)) = do-  newSpan <- uniqueSrcSpanT-  logTr $ "decl2SigT:newSpan=" ++ showGhc newSpan-  let-    duplicateAnn ans =-      case Map.lookup (mkAnnKey vs) ans of-        Nothing -> ans-        Just ann -> Map.insert (mkAnnKey (GHC.L newSpan s)) ann ans-  modifyAnnsT duplicateAnn-  return [GHC.L newSpan s]-decl2SigT _ = return []+-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'+wrapDecl :: GHC.LHsBind GHC.RdrName -> GHC.LHsDecl GHC.RdrName+wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)  -- --------------------------------------------------------------------- @@ -299,6 +267,20 @@  -- --------------------------------------------------------------------- +-- |Add a trailing comma annotation, unless there is already one+addTrailingCommaT :: (Data a) => GHC.Located a -> Transform ()+addTrailingCommaT ast = do+  modifyAnnsT (addTrailingComma ast (DP (0,0)))++-- ---------------------------------------------------------------------++-- |Remove a trailing comma annotation, if there is one one+removeTrailingCommaT :: (Data a) => GHC.Located a -> Transform ()+removeTrailingCommaT ast = do+  modifyAnnsT (removeTrailingComma ast)++-- ---------------------------------------------------------------------+ -- |'Transform' monad version of 'getEntryDP' getEntryDPT :: (Data a) => GHC.Located a -> Transform DeltaPos getEntryDPT ast = do@@ -307,6 +289,34 @@  -- --------------------------------------------------------------------- +-- |'Transform' monad version of 'getEntryDP'+setEntryDPT :: (Data a) => GHC.Located a -> DeltaPos -> Transform ()+setEntryDPT ast dp = do+  modifyAnnsT (setEntryDP ast dp)++-- ---------------------------------------------------------------------++-- |'Transform' monad version of 'transferEntryDP'+transferEntryDPT :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()+transferEntryDPT a b =+  modifyAnnsT (transferEntryDP a b)++-- ---------------------------------------------------------------------++-- |'Transform' monad version of 'setPrecedingLinesDecl'+setPrecedingLinesDeclT ::  GHC.LHsDecl GHC.RdrName -> Int -> Int -> Transform ()+setPrecedingLinesDeclT ld n c =+  modifyAnnsT (setPrecedingLinesDecl ld n c)++-- ---------------------------------------------------------------------++-- |'Transform' monad version of 'setPrecedingLines'+setPrecedingLinesT ::  (SYB.Data a) => GHC.Located a -> Int -> Int -> Transform ()+setPrecedingLinesT ld n c =+  modifyAnnsT (setPrecedingLines ld n c)++-- ---------------------------------------------------------------------+ -- | Left bias pair union mergeAnns :: Anns -> Anns -> Anns mergeAnns@@ -320,42 +330,15 @@ -- ---------------------------------------------------------------------  -- |Unwrap a HsDecl and call setPrecedingLines on it+-- ++AZ++ TODO: get rid of this, it is a synonym only setPrecedingLinesDecl :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Anns -> Anns-setPrecedingLinesDecl ld n c ans =-  declFun (\a -> setPrecedingLines a n c ans') ld-  where-    ans' = Map.insert (mkAnnKey ld) annNone ans--declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b-declFun f (GHC.L l de) =-  case de of-      GHC.TyClD d       -> f (GHC.L l d)-      GHC.InstD d       -> f (GHC.L l d)-      GHC.DerivD d      -> f (GHC.L l d)-      GHC.ValD d        -> f (GHC.L l d)-      GHC.SigD d        -> f (GHC.L l d)-      GHC.DefD d        -> f (GHC.L l d)-      GHC.ForD d        -> f (GHC.L l d)-      GHC.WarningD d    -> f (GHC.L l d)-      GHC.AnnD d        -> f (GHC.L l d)-      GHC.RuleD d       -> f (GHC.L l d)-      GHC.VectD d       -> f (GHC.L l d)-      GHC.SpliceD d     -> f (GHC.L l d)-      GHC.DocD d        -> f (GHC.L l d)-      GHC.RoleAnnotD d  -> f (GHC.L l d)-#if __GLASGOW_HASKELL__ < 711-      GHC.QuasiQuoteD d -> f (GHC.L l d)-#endif+setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans  -- ---------------------------------------------------------------------  -- | Adjust the entry annotations to provide an `n` line preceding gap setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns-setPrecedingLines ast n c anne =-  Map.alter go (mkAnnKey ast) anne-  where-    go Nothing  = Just (annNone { annEntryDelta = DP (n, c) })-    go (Just a) = Just (a       { annEntryDelta = DP (n, c) })+setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne  -- --------------------------------------------------------------------- @@ -369,20 +352,114 @@  -- --------------------------------------------------------------------- +-- |Set the true entry 'DeltaPos' from the annotation for a given AST+-- element. This is the 'DeltaPos' ignoring any comments.+setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns+setEntryDP ast dp anns =+  case Map.lookup (mkAnnKey ast) anns of+    Nothing  -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns+    Just ann -> Map.insert (mkAnnKey ast) (ann'    { annEntryDelta = annCommentEntryDelta ann' dp}) anns+      where+        ann' = setCommentEntryDP ann dp++-- ---------------------------------------------------------------------++-- |When setting an entryDP, the leading comment needs to be adjusted too+setCommentEntryDP :: Annotation -> DeltaPos -> Annotation+-- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann'+setCommentEntryDP ann dp = ann'+  where+    ann' = case (annPriorComments ann) of+      [] -> ann+      [(pc,_)]     -> ann { annPriorComments = [(pc,dp)] }+      ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) }++-- ---------------------------------------------------------------------++-- |Take the annEntryDelta associated with the first item and associate it with the second.+-- Also transfer any comments occuring before it.+transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns+transferEntryDP a b anns = (const anns2) anns+  where+    maybeAnns = do -- Maybe monad+      anA <- Map.lookup (mkAnnKey a) anns+      anB <- Map.lookup (mkAnnKey b) anns+      let anB'  = Ann+            { annEntryDelta        = DP (0,0) -- Need to adjust for comments after+            , annPriorComments     = annPriorComments     anB+            , annFollowingComments = annFollowingComments anB+            , annsDP               = annsDP          anB+            , annSortKey           = annSortKey      anB+            , annCapturedSpan      = annCapturedSpan anB+            }+      return ((Map.insert (mkAnnKey b) anB' anns),annLeadingCommentEntryDelta anA)+    (anns',dp) = fromMaybe+                  (error $ "transferEntryDP: lookup failed (a,b)=" ++ show (mkAnnKey a,mkAnnKey b))+                  maybeAnns+    anns2 = setEntryDP b dp anns'++-- ---------------------------------------------------------------------++addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns+addTrailingComma a dp anns =+  case Map.lookup (mkAnnKey a) anns of+    Nothing -> anns+    Just an ->+      case find isAnnComma (annsDP an) of+        Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G GHC.AnnComma,dp)]}) anns+        Just _  -> anns+      where+        isAnnComma (G GHC.AnnComma,_) = True+        isAnnComma _                  = False++-- ---------------------------------------------------------------------++removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns+removeTrailingComma a anns =+  case Map.lookup (mkAnnKey a) anns of+    Nothing -> anns+    Just an ->+      case find isAnnComma (annsDP an) of+        Nothing -> anns+        Just _  -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns+      where+        isAnnComma (G GHC.AnnComma,_) = True+        isAnnComma _                  = False++-- ---------------------------------------------------------------------++-- |The relatavise phase puts all comments appearing between the end of one AST+-- item and the beginning of the next as 'annPriorComments' for the second one.+-- This function takes two adjacent AST items and moves any 'annPriorComments'+-- from the second one to the 'annFollowingComments' of the first if they belong+-- to it instead. This is typically required before deleting or duplicating+-- either of the AST elements.+balanceComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()+balanceComments first second = do+  -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM+  -- logTr $ "balanceComments entered"+  -- logDataWithAnnsTr "first" first+  case cast first :: Maybe (GHC.LHsDecl GHC.RdrName) of+    Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do+      balanceCommentsFB (GHC.L l fb) second+    _ -> case cast first :: Maybe (GHC.LHsBind GHC.RdrName) of+      Just fb'@(GHC.L _ (GHC.FunBind{})) -> do+        balanceCommentsFB fb' second+      _ -> balanceComments' first second+ -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided -- with a passed-in decision function.-balanceComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()-balanceComments first second = do+balanceComments' :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()+balanceComments' first second = do   let     k1 = mkAnnKey first     k2 = mkAnnKey second     moveComments p ans = ans'       where-        an1 = gfromJust "balanceComments k1" $ Map.lookup k1 ans-        an2 = gfromJust "balanceComments k2" $ Map.lookup k2 ans-        -- cs1b = annPriorComments     an1+        an1 = gfromJust "balanceComments' k1" $ Map.lookup k1 ans+        an2 = gfromJust "balanceComments' k2" $ Map.lookup k2 ans         cs1f = annFollowingComments an1         cs2b = annPriorComments an2         (move,stay) = break p cs2b@@ -394,13 +471,24 @@    modifyAnnsT (moveComments simpleBreak) +-- |Once 'balanceComments' has been called to move trailing comments to a+-- 'GHC.FunBind', these need to be pushed down from the top level to the last+-- 'GHC.Match' if that 'GHC.Match' needs to be manipulated.+balanceCommentsFB :: (Data b) => GHC.LHsBind GHC.RdrName -> GHC.Located b -> Transform ()+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do+  -- logTr $ "balanceCommentsFB entered"+  balanceComments' (last matches) second+balanceCommentsFB f s = balanceComments' f s+ -- --------------------------------------------------------------------- + -- |After moving an AST element, make sure any comments that may belong -- with the following element in fact do. Of necessity this is a heuristic -- process, to be tuned later. Possibly a variant should be provided with a -- passed-in decision function.-balanceTrailingComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform [(Comment, DeltaPos)]+balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b+                        -> TransformT m [(Comment, DeltaPos)] balanceTrailingComments first second = do   let     k1 = mkAnnKey first@@ -412,16 +500,10 @@         cs1f = annFollowingComments an1         (move,stay) = break p cs1f         an1' = an1 { annFollowingComments = stay }-        an2' = an2 -- { annPriorComments = move ++ cs2b }-        -- an1' = an1 { annFollowingComments = [] }-        -- an2' = an2 { annPriorComments = cs1f ++ cs2b }-        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans-        -- ans' = error $ "balanceTrailingComments:(k1,k2)=" ++ showGhc (k1,k2)-        -- ans' = error $ "balanceTrailingComments:(cs1b,cs1f,cs2b,annFollowingComments an2)=" ++ showGhc (cs1b,cs1f,cs2b,annFollowingComments an2)+        ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans      simpleBreak (_,DP (r,_c)) = r > 0 -  -- modifyAnnsT (modifyKeywordDeltas (moveComments simpleBreak))   ans <- getAnnsT   let (ans',mov) = moveComments simpleBreak ans   putAnnsT ans'@@ -429,6 +511,7 @@  -- --------------------------------------------------------------------- +-- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for -- |Move any 'annFollowingComments' values from the 'Annotation' associated to -- the first parameter to that of the second. moveTrailingComments :: (Data a,Data b)@@ -451,20 +534,21 @@  -- --------------------------------------------------------------------- +-- |Insert a declaration into an AST element having sub-declarations+-- (@HasDecls@) according to the given location function. insertAt :: (Data ast, HasDecls (GHC.Located ast))-              => (GHC.SrcSpan -> [GHC.SrcSpan] -> [GHC.SrcSpan])+              => (GHC.LHsDecl GHC.RdrName+                  -> [GHC.LHsDecl GHC.RdrName]+                  -> [GHC.LHsDecl GHC.RdrName])               -> GHC.Located ast               -> GHC.LHsDecl GHC.RdrName               -> Transform (GHC.Located ast)-insertAt f m decl = do-  let newKey = GHC.getLoc decl-      modKey = mkAnnKey m-      newValue a@Ann{..} = a { annSortKey = f newKey <$> annSortKey }-  oldDecls <- hsDecls m-  modifyAnnsT (Map.adjust newValue modKey)--  replaceDecls m (decl : oldDecls )+insertAt f t decl = do+  oldDecls <- hsDecls t+  replaceDecls t (f decl oldDecls) +-- |Insert a declaration at the beginning or end of the subdecls of the given+-- AST item insertAtStart, insertAtEnd :: (Data ast, HasDecls (GHC.Located ast))               => GHC.Located ast               -> GHC.LHsDecl GHC.RdrName@@ -473,31 +557,38 @@ insertAtStart = insertAt (:) insertAtEnd   = insertAt (\x xs -> xs ++ [x]) +-- |Insert a declaration at a specific location in the subdecls of the given+-- AST item insertAfter, insertBefore :: (Data ast, HasDecls (GHC.Located ast))                           => GHC.Located old                           -> GHC.Located ast                           -> GHC.LHsDecl GHC.RdrName                           -> Transform (GHC.Located ast)--- insertAfter (mkAnnKey -> k) = insertAt findAfter insertAfter (GHC.getLoc -> k) = insertAt findAfter   where     findAfter x xs =-      let (fs, b:bs) = span (/= k) xs+      let (fs, b:bs) = span (\(GHC.L l _) -> l /= k) xs       in fs ++ (b : x : bs) insertBefore (GHC.getLoc -> k) = insertAt findBefore   where     findBefore x xs =-      let (fs, bs) = span (/= k) xs+      let (fs, bs) = span (\(GHC.L l _) -> l /= k) xs       in fs ++ (x : bs) --- ---------------------------------------------------------------------+-- =====================================================================+-- start of HasDecls instances+-- ===================================================================== +-- |Provide a means to get and process the immediate child declartions of a+-- given AST element. class (Data t) => HasDecls t where+-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent      -- | Return the 'GHC.HsDecl's that are directly enclosed in the     -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'-    -- form, even if orginating in local decls.-    hsDecls :: t -> Transform [GHC.LHsDecl GHC.RdrName]+    -- form, even if orginating in local decls. This is safe, as annotations+    -- never attach to the wrapper, only to the wrapped item.+    hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GHC.RdrName]      -- | Replace the directly enclosed decl list by the given     --  decl list. Runs in the 'Transform' monad to be able to update list order@@ -518,7 +609,7 @@     --   where     --     nn = 2     -- @-    replaceDecls :: t -> [GHC.LHsDecl GHC.RdrName] -> Transform t+    replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GHC.RdrName] -> TransformT m t  -- --------------------------------------------------------------------- @@ -526,40 +617,20 @@   hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls   replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls     = do+        logTr "replaceDecls LHsModule"         modifyAnnsT (captureOrder m decls)         return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks))  -- --------------------------------------------------------------------- -instance HasDecls (GHC.MatchGroup GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where-  hsDecls (GHC.MG matches _ _ _) = hsDecls matches--  replaceDecls (GHC.MG matches a r o) newDecls-    = do-        matches' <- replaceDecls matches newDecls-        return (GHC.MG matches' a r o)---- -----------------------------------------------------------------------instance HasDecls [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] where-  hsDecls ms = do-    ds <- mapM hsDecls ms-    return (concat ds)--  replaceDecls [] _        = error "empty match list in replaceDecls [GHC.LMatch GHC.Name]"-  replaceDecls ms newDecls-    = do-        -- ++AZ++: TODO: this one looks dodgy-        m' <- replaceDecls (ghead "replaceDecls" ms) newDecls-        return (m':tail ms)---- ---------------------------------------------------------------------- instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where-  hsDecls (GHC.L _ (GHC.Match _ _ _ grhs)) = hsDecls grhs+  hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do+    decls <- hsDeclsValBinds lb+    orderedDecls d decls    replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []     = do+        logTr "replaceDecls LMatch"         let           noWhere (G GHC.AnnWhere,_) = False           noWhere _                  = True@@ -569,18 +640,19 @@               Nothing -> error "wtf"               Just ann -> Map.insert (mkAnnKey m) ann1 mkds                 where-                  ann1 = ann { annsDP = filter noWhere (annsDP ann) +                  ann1 = ann { annsDP = filter noWhere (annsDP ann)                                  }         modifyAnnsT removeWhere -        binds' <- replaceDecls binds []+        binds' <- replaceDeclsValbinds binds []         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))    replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds     = do+        logTr "replaceDecls LMatch"         -- Need to throw in a fresh where clause if the binds were empty,         -- in the annotations.-        newBinds2 <- case binds of+        case binds of           GHC.EmptyLocalBinds -> do             let               addWhere mkds =@@ -591,172 +663,345 @@                       ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]                                  }             modifyAnnsT addWhere-            newBinds' <- mapM pushDeclAnnT newBinds-            modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')-            modifyAnnsT (setPrecedingLinesDecl (ghead "LMatch.replaceDecls" newBinds') 1 4)-            return newBinds'+            modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) -          _ -> do-            -- ++AZ++ TODO: move the duplicate code out of the case statement-            newBinds' <- mapM pushDeclAnnT newBinds-            modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')-            return newBinds'+            -- only move the comment if the original where clause was empty.+            toMove <- balanceTrailingComments m m+            insertCommentBefore (mkAnnKey m) toMove (matchApiAnn GHC.AnnWhere)+          _ -> return () -        binds' <- replaceDecls binds newBinds2+        modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds)+        binds' <- replaceDeclsValbinds binds newBinds+        -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'         return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))  -- --------------------------------------------------------------------- -instance HasDecls (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where-  hsDecls (GHC.GRHSs _ lb) = hsDecls lb+instance HasDecls (GHC.LHsExpr GHC.RdrName) where+  hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do+    ds <- hsDeclsValBinds decls+    orderedDecls ls ds+  hsDecls _                               = return [] -  replaceDecls (GHC.GRHSs rhss b) new+  replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls     = do-        b' <- replaceDecls b new-        return (GHC.GRHSs rhss b')+        logTr "replaceDecls HsLet"+        modifyAnnsT (captureOrder e newDecls)+        decls' <- replaceDeclsValbinds decls newDecls+        return (GHC.L l (GHC.HsLet decls' ex))+  replaceDecls (GHC.L l (GHC.HsPar e)) newDecls+    = do+        logTr "replaceDecls HsPar"+        e' <- replaceDecls e newDecls+        return (GHC.L l (GHC.HsPar e'))+  replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old  -- --------------------------------------------------------------------- -instance HasDecls (GHC.HsLocalBinds GHC.RdrName) where-  hsDecls lb = case lb of-    GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do-      bds <- mapM wrapDeclT (GHC.bagToList bs)-      sds <- mapM wrapSigT sigs-      -- ++AZ++ TODO: return in annotated order-      return (bds ++ sds)-    GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"-    GHC.HsIPBinds _     -> return []-    GHC.EmptyLocalBinds -> return []+-- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is+-- idempotent.+hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d)+hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x -  replaceDecls (GHC.HsValBinds _b) new-    = do-        let decs = GHC.listToBag $ concatMap decl2Bind new-        let sigs = concatMap decl2Sig new-        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))+-- | Extract the immediate declarations for a 'GHC.PatBind'. This+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is+-- idempotent.+hsDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do+  decls <- hsDeclsValBinds lb+  orderedDecls d decls+hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x -  replaceDecls (GHC.HsIPBinds _b) _new    = error "undefined replaceDecls HsIPBinds"+-- ------------------------------------- -  replaceDecls (GHC.EmptyLocalBinds) new+-- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is+-- idempotent.+replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]+                     -> TransformT m (GHC.LHsDecl GHC.RdrName)+replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do+  (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls+  return (GHC.L l (GHC.ValD d'))+replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x++-- | Replace the immediate declarations for a 'GHC.PatBind'. This+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is+-- idempotent.+replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]+                    -> TransformT m (GHC.LHsBind GHC.RdrName)+replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls     = do-        let newBinds = map decl2Bind new-            newSigs  = map decl2Sig  new-        ans <- getAnnsT-        logTr $ "replaceDecls:newBinds=" ++ showAnnData ans 0 newBinds-        let decs = GHC.listToBag $ concat newBinds-        let sigs = concat newSigs-        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))+        logTr "replaceDecls PatBind"+        -- Need to throw in a fresh where clause if the binds were empty,+        -- in the annotations.+        case binds of+          GHC.EmptyLocalBinds -> do+            let+              addWhere mkds =+                case Map.lookup (mkAnnKey p) mkds of+                  Nothing -> error "wtf"+                  Just ann -> Map.insert (mkAnnKey p) ann1 mkds+                    where+                      ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]+                                 }+            modifyAnnsT addWhere+            modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4) +          _ -> return ()++        modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)+        binds' <- replaceDeclsValbinds binds newDecls+        return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))+replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x+ -- --------------------------------------------------------------------- -instance HasDecls (GHC.LHsExpr GHC.RdrName) where-  hsDecls (GHC.L _ (GHC.HsLet decls _ex)) = hsDecls decls-  hsDecls _                               = return []+instance HasDecls (GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where+  hsDecls ls@(GHC.L _ (GHC.LetStmt lb))       = do+    decls <- hsDeclsValBinds lb+    orderedDecls ls decls+  hsDecls (GHC.L _ (GHC.LastStmt e _))        = hsDecls e+  hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e+  hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _))    = hsDecls e+  hsDecls _                                   = return [] -  replaceDecls (GHC.L l (GHC.HsLet decls ex)) newDecls+  replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls     = do-        decls' <- replaceDecls decls newDecls-        return (GHC.L l (GHC.HsLet decls' ex))-  replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old+        modifyAnnsT (captureOrder s newDecls)+        lb' <- replaceDeclsValbinds lb newDecls+        return (GHC.L l (GHC.LetStmt lb'))+  replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls+    = do+        e' <- replaceDecls e newDecls+        return (GHC.L l (GHC.LastStmt e' se))+  replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls+    = do+      e' <- replaceDecls e newDecls+      return (GHC.L l (GHC.BindStmt pat e' a b))+  replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls+    = do+      e' <- replaceDecls e newDecls+      return (GHC.L l (GHC.BodyStmt e' a b c))+  replaceDecls x _newDecls = return x +-- =====================================================================+-- end of HasDecls instances+-- =====================================================================+ -- --------------------------------------------------------------------- -instance HasDecls (GHC.LHsBinds GHC.RdrName) where-  hsDecls binds = hsDecls $ GHC.bagToList binds-  replaceDecls old _new = error $ "replaceDecls (GHC.LHsBinds name) undefined for:" ++ (showGhc old)+-- |Do a transformation on an AST fragment by providing a function to process+-- the general case and one specific for a 'GHC.LHsBind'. This is required+-- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot+-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.+hasDeclsSybTransform :: (SYB.Data t2, SYB.Typeable t2,Monad m)+       => (forall t. HasDecls t => t -> m t)+             -- ^Worker function for the general case+       -> (GHC.LHsBind GHC.RdrName -> m (GHC.LHsBind GHC.RdrName))+             -- ^Worker function for FunBind/PatBind+       -> t2 -- ^Item to be updated+       -> m t2+hasDeclsSybTransform workerHasDecls workerBind t = trf t+  where+    trf = SYB.mkM   parsedSource+         `SYB.extM` lmatch+         `SYB.extM` lexpr+         `SYB.extM` lstmt+         `SYB.extM` lhsbind+         `SYB.extM` lvald +    parsedSource (p::GHC.ParsedSource) = workerHasDecls p++    lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+      = workerHasDecls lm++    lexpr (le::GHC.LHsExpr GHC.RdrName)+      = workerHasDecls le++    lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName))+      = workerHasDecls d++    lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GHC.RdrName)+      = workerBind b+    lhsbind b@(GHC.L _ GHC.PatBind{})+      = workerBind b+    lhsbind x = return x++    lvald (GHC.L l (GHC.ValD d)) = do+      (GHC.L _ d') <- lhsbind (GHC.L l d)+      return (GHC.L l (GHC.ValD d'))+    lvald x = return x+ -- --------------------------------------------------------------------- -instance HasDecls [GHC.LHsBind GHC.RdrName] where-  hsDecls bs = mapM wrapDeclT bs+-- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot+-- return anything for these as there is not meaningful 'replaceDecls' for it.+-- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind'+-- decls too, where they are needed for analysis only.+hsDeclsGeneric :: (SYB.Data t,SYB.Typeable t) => t -> Transform [GHC.LHsDecl GHC.RdrName]+hsDeclsGeneric t = q t+  where+    q = return []+        `SYB.mkQ`  parsedSource+        `SYB.extQ` lmatch+        `SYB.extQ` lexpr+        `SYB.extQ` lstmt+        `SYB.extQ` lhsbind+        `SYB.extQ` lhsbindd+        `SYB.extQ` localbinds -  replaceDecls _bs newDecls-    = do-        return $ concatMap decl2Bind newDecls+    parsedSource (p::GHC.ParsedSource) = hsDecls p +    lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls lm++    lexpr (le::GHC.LHsExpr GHC.RdrName) = hsDecls le++    lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls d++    -- ---------------------------------++    lhsbind :: GHC.LHsBind GHC.RdrName -> Transform [GHC.LHsDecl GHC.RdrName]+    lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do+        dss <- mapM hsDecls matches+        return (concat dss)+    lhsbind p@(GHC.L _ (GHC.PatBind{})) = do+      hsDeclsPatBind p+    lhsbind _ = return []++    -- ---------------------------------++    lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)+    lhsbindd _ = return []++    -- ---------------------------------++    localbinds :: GHC.HsLocalBinds GHC.RdrName -> Transform [GHC.LHsDecl GHC.RdrName]+    localbinds d = hsDeclsValBinds d+ -- --------------------------------------------------------------------- -instance HasDecls (GHC.LHsBind GHC.RdrName) where-  hsDecls (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsDecls matches-  hsDecls (GHC.L _ (GHC.PatBind _ rhs _ _ _))       = hsDecls rhs-  hsDecls (GHC.L _ (GHC.VarBind _ rhs _))           = hsDecls rhs-  hsDecls (GHC.L _ (GHC.AbsBinds _ _ _ _ binds))    = hsDecls binds-  hsDecls (GHC.L _ (GHC.PatSynBind _))      = error "hsDecls: PatSynBind to implement"+-- |Look up the annotated order and sort the decls accordingly+orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GHC.RdrName] -> TransformT m [GHC.LHsDecl GHC.RdrName]+orderedDecls parent decls = do+  ans <- getAnnsT+  case getAnnotationEP parent ans of+    Nothing -> error $ "orderedDecls:no annotation for:" ++ showAnnData emptyAnns 0 parent+    Just ann -> case annSortKey ann of+      Nothing -> do+        return decls+      Just keys -> do+        let ds = map (\s -> (GHC.getLoc s,s)) decls+            ordered = orderByKey ds keys+        return ordered +-- --------------------------------------------------------------------- -  replaceDecls (GHC.L l fn@(GHC.FunBind a b (GHC.MG matches f g h) c d e)) newDecls-    = do-        matches' <- replaceDecls matches newDecls-        case matches' of-          [] -> return () -- Should be impossible-          ms -> do-            case (GHC.grhssLocalBinds $ GHC.m_grhss $ GHC.unLoc $ last matches) of-              GHC.EmptyLocalBinds -> do-                -- only move the comment if the original where clause was empty.-                toMove <- balanceTrailingComments (GHC.L l (GHC.ValD fn)) (last matches')-                insertCommentBefore (mkAnnKey $ last ms) toMove (matchApiAnn GHC.AnnWhere)-              lbs -> do-                decs <- hsDecls lbs-                balanceComments (last decs) (GHC.L l (GHC.ValD fn))-        return (GHC.L l (GHC.FunBind a b (GHC.MG matches' f g h) c d e))+-- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with+-- care, as this does not necessarily return the declarations in order, the+-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'+-- context in the AST.+hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]+hsDeclsValBinds lb = case lb of+    GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do+      let+        bds = map wrapDecl (GHC.bagToList bs)+        sds = map wrapSig sigs+      return (bds ++ sds)+    GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"+    GHC.HsIPBinds _     -> return []+    GHC.EmptyLocalBinds -> return [] -  replaceDecls (GHC.L l (GHC.PatBind a rhs b c d)) newDecls-    = do-        rhs' <- replaceDecls rhs newDecls-        return (GHC.L l (GHC.PatBind a rhs' b c d))-  replaceDecls (GHC.L l (GHC.VarBind a rhs b)) newDecls+-- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with+-- care, as this does not manage the declaration order, the+-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'+-- context in the AST.+replaceDeclsValbinds :: (Monad m)+                     => GHC.HsLocalBinds GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]+                     -> TransformT m (GHC.HsLocalBinds GHC.RdrName)+replaceDeclsValbinds _ [] = do+  return (GHC.EmptyLocalBinds)+replaceDeclsValbinds (GHC.HsValBinds _b) new     = do-        rhs' <- replaceDecls rhs newDecls-        return (GHC.L l (GHC.VarBind a rhs' b))-  replaceDecls (GHC.L l (GHC.AbsBinds a b c d binds)) newDecls+        logTr "replaceDecls HsLocalBinds"+        let decs = GHC.listToBag $ concatMap decl2Bind new+        let sigs = concatMap decl2Sig new+        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))+replaceDeclsValbinds (GHC.HsIPBinds _b) _new    = error "undefined replaceDecls HsIPBinds"+replaceDeclsValbinds (GHC.EmptyLocalBinds) new     = do-        binds' <- replaceDecls binds newDecls-        return (GHC.L l (GHC.AbsBinds a b c d binds'))-  replaceDecls (GHC.L _ (GHC.PatSynBind _)) _ = error "replaceDecls: PatSynBind to implement"+        logTr "replaceDecls HsLocalBinds"+        let newBinds = map decl2Bind new+            newSigs  = map decl2Sig  new+        let decs = GHC.listToBag $ concat newBinds+        let sigs = concat newSigs+        return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))  -- --------------------------------------------------------------------- -instance HasDecls (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where-  hsDecls (GHC.LetStmt lb)          = hsDecls lb-  hsDecls (GHC.LastStmt e _)        = hsDecls e-  hsDecls (GHC.BindStmt _pat e _ _) = hsDecls e-  hsDecls (GHC.BodyStmt e _ _ _)    = hsDecls e-  hsDecls _                         = return []+type Decl  = GHC.LHsDecl GHC.RdrName+type Match = GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -  replaceDecls (GHC.LetStmt lb) newDecls-    = do-      lb' <- replaceDecls lb newDecls-      return (GHC.LetStmt lb')-  replaceDecls (GHC.LastStmt e se) newDecls-    = do-        e' <- replaceDecls e newDecls-        return (GHC.LastStmt e' se)-  replaceDecls (GHC.BindStmt pat e a b) newDecls-    = do-      e' <- replaceDecls e newDecls-      return (GHC.BindStmt pat e' a b)-  replaceDecls (GHC.BodyStmt e a b c) newDecls-    = do-      e' <- replaceDecls e newDecls-      return (GHC.BodyStmt e' a b c)-  replaceDecls x newDecls = return x+-- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the+-- declarations are extracted and returned after modification. For a+-- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific+-- 'GHC.Match' to be transformed, for when there are multiple of them.+modifyValD :: forall m t. (HasTransform m)+                => GHC.SrcSpan+                -> Decl+                -> (Match -> [Decl] -> m ([Decl], Maybe t))+                -> m (Decl,Maybe t)+modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f =+  if ss == p+     then do+       ds <- liftT $ hsDeclsPatBindD pb+       (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds+       pb' <- liftT $ replaceDeclsPatBindD pb ds'+       return (pb',r)+     else return (pb,Nothing)+modifyValD p ast f = do+  (ast',r) <- runStateT (SYB.everywhereM (SYB.mkM doModLocal) ast) Nothing+  return (ast',r)+  where+    doModLocal :: Match -> StateT (Maybe t) m Match+    doModLocal  (match@(GHC.L ss _) :: Match) = do+         let+         if ss == p+           then do+             ds <- lift $ liftT $ hsDecls match+             (ds',r) <- lift $ f match ds+             put r+             match' <- lift $ liftT $ replaceDecls match ds'+             return match'+           else return match  -- --------------------------------------------------------------------- -instance HasDecls (GHC.LHsDecl GHC.RdrName) where-  hsDecls (GHC.L l (GHC.ValD d)) = hsDecls (GHC.L l d)-  -- hsDecls (GHC.L l (GHC.SigD d)) = hsDecls (GHC.L l d)-  hsDecls _                      = return []+-- |Used to integrate a @Transform@ into other Monad stacks+class (Monad m) => (HasTransform m) where+  liftT :: Transform a -> m a -  replaceDecls (GHC.L l (GHC.ValD d)) newDecls = do-    (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls-    return (GHC.L l1 (GHC.ValD d1))-  -- replaceDecls (GHC.L l (GHC.SigD d)) newDecls = do-  --   (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls-  --   return (GHC.L l1 (GHC.SigD d1))-  replaceDecls _d _  = error $ "LHsDecl.replaceDecls:not implemented"+instance HasTransform (TransformT Identity) where+  liftT = id  -- --------------------------------------------------------------------- +-- | Apply a transformation to the decls contained in @t@+modifyDeclsT :: (HasDecls t,HasTransform m)+             => ([GHC.LHsDecl GHC.RdrName] -> m [GHC.LHsDecl GHC.RdrName])+             -> t -> m t+modifyDeclsT action t = do+  decls <- liftT $ hsDecls t+  decls' <- action decls+  liftT $ replaceDecls t decls'++-- ---------------------------------------------------------------------+ matchApiAnn :: GHC.AnnKeywordId -> (KeywordId,DeltaPos) -> Bool matchApiAnn mkw (kw,_)   = case kw of@@ -767,8 +1012,8 @@ -- We comments extracted from annPriorComments or annFollowingComments, which -- need to move to just before the item identified by the predicate, if it -- fires, else at the end of the annotations.-insertCommentBefore :: AnnKey -> [(Comment, DeltaPos)]-                    -> ((KeywordId, DeltaPos) -> Bool) -> Transform ()+insertCommentBefore :: (Monad m) => AnnKey -> [(Comment, DeltaPos)]+                    -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m () insertCommentBefore key toMove p = do   let     doInsert ans =@@ -777,7 +1022,6 @@         Just ann -> Map.insert key ann' ans           where             (before,after) = break p (annsDP ann)-            -- ann' = error $ "insertCommentBefore:" ++ showGhc (before,after)             ann' = ann { annsDP = before ++ (map comment2dp toMove) ++ after}    modifyAnnsT doInsert

@@ -1,6 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.GHC.ExactPrint.Types   ( -- * Core Types    Anns@@ -21,10 +24,11 @@   , annGetConstr   -- * Internal Types   , LayoutStartCol(..)+  , declFun    ) where -import Data.Data (Data, Typeable, toConstr)+import Data.Data (Data, Typeable, toConstr,cast)  import qualified DynFlags       as GHC import qualified GHC@@ -43,7 +47,9 @@     , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents     , commentOrigin     :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.     }-  deriving (Eq,Show,Typeable,Data, Ord)+  deriving (Eq,Typeable,Data,Ord)+instance Show Comment where+  show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"  instance GHC.Outputable Comment where   ppr x = GHC.text (show x)@@ -71,6 +77,7 @@  data Annotation = Ann   {+    -- The first three fields relate to interfacing up into the AST     annEntryDelta      :: !DeltaPos     -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior     -- output was, including all annPriorComments (field below).@@ -83,6 +90,8 @@     -- ^ Comments coming after the last output for the element subject to this     -- Annotation. These will only be added by AST transformations, and care     -- must be taken not to disturb layout of following elements.++  -- The next three fields relate to interacing down into the AST   , annsDP             :: ![(KeywordId, DeltaPos)]     -- ^ Annotations associated with this element.   , annSortKey         :: !(Maybe [GHC.SrcSpan])@@ -126,9 +135,15 @@ instance Show AnnKey where   show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn -mkAnnKey :: (Data a) => GHC.Located a -> AnnKey-mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a)+mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey+mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) +-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.+mkAnnKey :: (Data a) => GHC.Located a -> AnnKey+mkAnnKey ld =+  case cast ld :: Maybe (GHC.LHsDecl GHC.RdrName) of+    Just d -> declFun mkAnnKeyPrim d+    Nothing -> mkAnnKeyPrim ld  -- Holds the name of a constructor data AnnConName = CN { unConName :: String }@@ -178,6 +193,27 @@   ppr a     = GHC.text (show a)  -- ---------------------------------------------------------------------++declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b+declFun f (GHC.L l de) =+  case de of+      GHC.TyClD d       -> f (GHC.L l d)+      GHC.InstD d       -> f (GHC.L l d)+      GHC.DerivD d      -> f (GHC.L l d)+      GHC.ValD d        -> f (GHC.L l d)+      GHC.SigD d        -> f (GHC.L l d)+      GHC.DefD d        -> f (GHC.L l d)+      GHC.ForD d        -> f (GHC.L l d)+      GHC.WarningD d    -> f (GHC.L l d)+      GHC.AnnD d        -> f (GHC.L l d)+      GHC.RuleD d       -> f (GHC.L l d)+      GHC.VectD d       -> f (GHC.L l d)+      GHC.SpliceD d     -> f (GHC.L l d)+      GHC.DocD d        -> f (GHC.L l d)+      GHC.RoleAnnotD d  -> f (GHC.L l d)+#if __GLASGOW_HASKELL__ < 711+      GHC.QuasiQuoteD d -> f (GHC.L l d)+#endif   -- ---------------------------------------------------------------------

@@ -1,5 +1,7 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.GHC.ExactPrint.Utils   (    -- * Manipulating Positons@@ -20,7 +22,7 @@   , comment2dp      -- * GHC Functions-  ,  srcSpanStartLine+  , srcSpanStartLine   , srcSpanEndLine   , srcSpanStartColumn   , srcSpanEndColumn@@ -33,12 +35,13 @@   -- * Manipulating Annotations   , getAnnotationEP   , annTrueEntryDelta+  , annCommentEntryDelta+  , annLeadingCommentEntryDelta    -- * General Utility   , orderByKey  -   -- * For tests   , debug   , debugM@@ -135,9 +138,10 @@     fl = l + dl     fc = if dl == 0 then c  + dc                     else co + dc+ -- | Add together two @DeltaPos@ taking into account newlines ----- > DP (0, 1) `addDP` DP (0, 2) == DP (0,3)+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3) -- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5) -- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3) addDP :: DeltaPos -> DeltaPos -> DeltaPos@@ -145,6 +149,33 @@   if c >= 1 then DP (a+c, d)             else DP (a, b + d) +-- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the+-- remaining delta for the second after the first has been applied.+-- invariant : if c = a `addDP` b+--             then a `stepDP` c == b+--+-- Cases where first DP is <= than second+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1)+-- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0)+-- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1)+-- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4)+--+-- Cases where first DP is > than second+-- > DP (0,  3) `addDP` DP (0, 2) == DP (0,1)  -- advance one at least+-- > DP (3,  3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col+-- > DP (3,  3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least+-- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col+stepDP :: DeltaPos -> DeltaPos -> DeltaPos+stepDP (DP (a,b)) (DP (c,d))+  | (a,b) == (c,d) = DP (a,b)+  | a == c = if b < d then DP (0,d - b)+                      else if d == 0+                             then DP (1,0)+                             -- else DP (0,1)+                             else DP (c,d)+  | a < c = DP (c - a,d)+  | otherwise = DP (1,d)+ -- ---------------------------------------------------------------------  ss2pos :: GHC.SrcSpan -> Pos@@ -242,6 +273,23 @@   foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )     `addDP` annEntryDelta +-- | Take an annotation and a required "true entry" and calculate an equivalent+-- one relative to the last comment in the annPriorComments.+annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos+annCommentEntryDelta Ann{annPriorComments} trueDP = dp+  where+    commentDP =+      foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )+    dp = stepDP commentDP trueDP++-- | Return the DP of the first item that generates output, either a comment or the entry DP+annLeadingCommentEntryDelta :: Annotation -> DeltaPos+annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp+  where+    dp = case annPriorComments of+      [] -> annEntryDelta+      ((_,ed):_) -> ed+ -- | Calculates the distance from the start of a string to the end of -- a string. dpFromString ::  String -> DeltaPos@@ -333,13 +381,23 @@                       srcSpan s                       ++ indent (n + 1) ++                       show (getAnnotationEP (GHC.L s a) anns)+                      -- ++ case showWrappedDeclAnns (GHC.L s a) of+                      --   Nothing -> ""+                      --   Just annStr  -> indent (n + 1) ++ annStr                     Nothing -> "nnnnnnnn"                   ++ showAnnData anns (n+1) a                   ++ ")" --- ----------------------------------------------------------------------+{-+        showWrappedDeclAnns :: (Data a) => GHC.Located a -> Maybe String+        showWrappedDeclAnns t = everything mappend (Nothing `mkQ` showDecl) t+          where+            showDecl :: GHC.LHsDecl GHC.RdrName -> Maybe String+            showDecl d = Just $ declFun doShowAnn  d +        doShowAnn :: (Data a) => GHC.Located a -> String+        doShowAnn a =  show (getAnnotationEP a anns)+-}  -- ---------------------------------------------------------------------  showSDoc_ :: GHC.SDoc -> String

@@ -39,6 +39,14 @@      then exitFailure      else return () -- exitSuccess +transform :: IO ()+transform = hSilence [stderr] $ do+  cnts <- fst <$> runTestText (putTextToHandle stdout True) (TestList transformTests)+  putStrLn $ show cnts+  if errors cnts > 0 || failures cnts > 0+     then exitFailure+     else return () -- exitSuccess+ -- ---------------------------------------------------------------------  tests :: Test@@ -234,6 +242,7 @@   , mkParserTest "T10196.hs"   , mkParserTest "StringGap.hs"   , mkParserTest "RedundantDo.hs"+  , mkParserTest "TypeSignature.hs"   ]    ++ transformTests@@ -463,16 +472,31 @@     -- , manipulateAstTestWFname "WhereIn3.hs"                 "WhereIn3"     -- , manipulateAstTestWFnameMod changeWhereIn3a "WhereIn3a.hs" "WhereIn3a"     -- , manipulateAstTestWFname "Imports.hs"              "Imports"-    , manipulateAstTestWFname "T10196.hs"               "T10196"+    -- , manipulateAstTestWFname "T10196.hs"               "T10196"     , manipulateAstTestWFnameMod addLocaLDecl1 "AddLocalDecl1.hs" "AddLocaLDecl1"-    , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2"-    , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3"-    , manipulateAstTestWFnameMod rmDecl1       "RmDecl1.hs"       "RmDecl1"+    -- , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2"+    -- , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3"+    -- , manipulateAstTestWFnameMod addLocaLDecl4 "AddLocalDecl4.hs" "AddLocaLDecl4"+    -- , manipulateAstTestWFnameMod addLocaLDecl5 "AddLocalDecl5.hs" "AddLocaLDecl5"+    -- , manipulateAstTestWFnameMod addLocaLDecl6 "AddLocalDecl6.hs" "AddLocaLDecl6"+    -- , manipulateAstTestWFnameMod rmDecl1       "RmDecl1.hs"       "RmDecl1"     -- , manipulateAstTestWFname "RmDecl2.hs"                        "RmDecl2"-    , manipulateAstTestWFnameMod rmDecl2       "RmDecl2.hs"       "RmDecl2"-    , manipulateAstTestWFnameMod rmDecl3       "RmDecl3.hs"       "RmDecl3"-    , manipulateAstTestWFnameMod rmTypeSig1    "RmTypeSig1.hs"    "RmTypeSig1"-    , manipulateAstTestWFname "StringGap.hs"                      "StringGap"+    -- , manipulateAstTestWFnameMod rmDecl2       "RmDecl2.hs"       "RmDecl2"+    -- , manipulateAstTestWFnameMod rmDecl3       "RmDecl3.hs"       "RmDecl3"+    -- , manipulateAstTestWFnameMod rmDecl4       "RmDecl4.hs"       "RmDecl4"+    -- , manipulateAstTestWFnameMod rmDecl5       "RmDecl5.hs"       "RmDecl5"+    -- , manipulateAstTestWFname "RmDecl5.hs"                        "RmDecl5"+    -- , manipulateAstTestWFnameMod rmDecl6       "RmDecl6.hs"       "RmDecl6"+    -- , manipulateAstTestWFnameMod rmDecl7       "RmDecl7.hs"       "RmDecl7"+    -- , manipulateAstTestWFname "TypeSignature.hs"                  "TypeSignature"+    -- , manipulateAstTestWFnameMod rmTypeSig1    "RmTypeSig1.hs"    "RmTypeSig1"+    -- , manipulateAstTestWFnameMod rmTypeSig2    "RmTypeSig2.hs"    "RmTypeSig2"+    -- , manipulateAstTestWFname "StringGap.hs"                      "StringGap"+    -- , manipulateAstTestWFnameMod addHiding1    "AddHiding1.hs"    "AddHiding1"+    -- , manipulateAstTestWFnameMod addHiding2    "AddHiding2.hs"    "AddHiding2"+    -- , manipulateAstTestWFnameMod cloneDecl1    "CloneDecl1.hs"    "CloneDecl1"+    -- , manipulateAstTestWFname "SimpleDo.hs"                      "Main"+    -- , manipulateAstTestWFnameMod changeRename2    "Rename2.hs"  "Main"     {-     , manipulateAstTestWFname "Lhs.lhs"                  "Main"     , manipulateAstTestWFname "Foo.hs"                   "Main"

@@ -155,7 +155,7 @@ runRoundTrip !anns !parsedOrig cs =   let     !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns-    !printed = exactPrintWithAnns parsedOrig relAnns+    !printed = exactPrint parsedOrig relAnns   in (printed,  relAnns)  -- ---------------------------------------------------------------------`

@@ -18,11 +18,13 @@ import qualified FastString     as GHC  import qualified Data.Generics as SYB+-- import qualified GHC.SYB.Utils as SYB  import Control.Monad import System.FilePath import System.IO import qualified Data.Map as Map+-- import Data.List import Data.Maybe  import System.IO.Silently@@ -46,6 +48,7 @@   , mkTestModChange changeLayoutLet3  "LayoutLet3.hs"  "LayoutLet3"   , mkTestModChange changeLayoutLet3  "LayoutLet4.hs"  "LayoutLet4"   , mkTestModChange changeRename1     "Rename1.hs"     "Main"+  , mkTestModChange changeRename2     "Rename2.hs"     "Main"   , mkTestModChange changeLayoutIn1   "LayoutIn1.hs"   "LayoutIn1"   , mkTestModChange changeLayoutIn3   "LayoutIn3.hs"   "LayoutIn3"   , mkTestModChange changeLayoutIn3   "LayoutIn3a.hs"  "LayoutIn3a"@@ -115,7 +118,7 @@                              { annEntryDelta     = DP (1,0) }         modifyAnnsT addWhere         let decls = [s,d]-        logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)+        -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrderAnnKey newAnnKey decls)         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs                         (GHC.HsValBinds@@ -149,11 +152,9 @@                 let a2 = setPrecedingLines s1 2 0 a1                 return a2         putAnnsT a'-        let wrapDecl (GHC.L l' w) = GHC.L l' (GHC.ValD w)-            wrapSig (GHC.L l' w) = GHC.L l' (GHC.SigD w)         let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs         let decls = s:d:oldDecls-        logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)+        -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)         modifyAnnsT (captureOrder m decls)         return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs                         (GHC.HsValBinds@@ -323,6 +324,9 @@ changeRename1 :: Changer changeRename1 ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed) +changeRename2 :: Changer+changeRename2 ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed)+ changeLayoutLet3 :: Changer changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) @@ -448,7 +452,7 @@                    Just (change,_) -> change ann parsed    let-    printed = exactPrintWithAnns parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))+    printed = exactPrint parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))     outcome = if printed == contents                 then "Match\n"                 else "Fail\n"@@ -552,97 +556,173 @@     mkTestModChange addLocaLDecl1  "AddLocalDecl1.hs"  "AddLocalDecl1"   , mkTestModChange addLocaLDecl2  "AddLocalDecl2.hs"  "AddLocalDecl2"   , mkTestModChange addLocaLDecl3  "AddLocalDecl3.hs"  "AddLocalDecl3"+  , mkTestModChange addLocaLDecl4  "AddLocalDecl4.hs"  "AddLocalDecl4"+  , mkTestModChange addLocaLDecl5  "AddLocalDecl5.hs"  "AddLocalDecl5"+  , mkTestModChange addLocaLDecl6  "AddLocalDecl6.hs"  "AddLocalDecl6"    , mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1"   , mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2"   , mkTestModChange rmDecl3 "RmDecl3.hs" "RmDecl3"+  , mkTestModChange rmDecl4 "RmDecl4.hs" "RmDecl4"+  , mkTestModChange rmDecl5 "RmDecl5.hs" "RmDecl5"+  , mkTestModChange rmDecl6 "RmDecl6.hs" "RmDecl6"+  , mkTestModChange rmDecl7 "RmDecl7.hs" "RmDecl7"    , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"+  , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" "RmTypeSig2"++  , mkTestModChange addHiding1 "AddHiding1.hs" "AddHiding1"+  , mkTestModChange addHiding2 "AddHiding2.hs" "AddHiding2"++  , mkTestModChange cloneDecl1 "CloneDecl1.hs" "CloneDecl1"   ]  -- ---------------------------------------------------------------------  addLocaLDecl1 :: Changer addLocaLDecl1 ans lp = do-  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns+  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  let declAnns' = setPrecedingLines newDecl 1 4 declAnns+      doAddLocal = do+        (d1:d2:_) <- hsDecls lp+        balanceComments d1 d2+        (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do+          return ((newDecl : d),Nothing)+        replaceDecls lp [d1', d2] +  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal+  -- putStrLn $ "log:\n" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++addLocaLDecl2 :: Changer+addLocaLDecl2 ans lp = do+  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  let       doAddLocal = do          tlDecs <- hsDecls lp          let parent = head tlDecs-         decls <- hsDecls parent          balanceComments parent (head $ tail tlDecs) -         modifyAnnsT (setPrecedingLines newDecl 1 4)+         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do+           transferEntryDPT (head decls) newDecl+           setEntryDPT (head decls) (DP (1, 0))+           return ((newDecl:decls),Nothing) -         parent' <- replaceDecls parent (newDecl:decls)          replaceDecls lp (parent':tail tlDecs) -  let (lp',(ans',_),_w) = runTransform ans doAddLocal-  return (mergeAnnList [declAnns',ans'],lp')+  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal+  -- putStrLn $ "log:\n" ++ intercalate "\n" _w+  return (ans',lp')  -- --------------------------------------------------------------------- -addLocaLDecl2 :: Changer-addLocaLDecl2 ans lp = do-  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns-+addLocaLDecl3 :: Changer+addLocaLDecl3 ans lp = do+  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  let       doAddLocal = do+         -- logDataWithAnnsTr "parsed:" lp+         logDataWithAnnsTr "newDecl:" newDecl          tlDecs <- hsDecls lp          let parent = head tlDecs-         decls <- hsDecls parent          balanceComments parent (head $ tail tlDecs) -         DP (r,c) <- getEntryDPT (head decls)-         modifyAnnsT (setPrecedingLines newDecl r c)-         modifyAnnsT (setPrecedingLines (head decls) 1 0)+         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do+           setPrecedingLinesT newDecl 1 0+           moveTrailingComments m (last decls)+           return ((decls++[newDecl]),Nothing) -         parent' <- replaceDecls parent (newDecl:decls)          replaceDecls lp (parent':tail tlDecs) -  let (lp',(ans',_),_w) = runTransform ans doAddLocal-  return (mergeAnnList [declAnns',ans'],lp')+  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal+  -- putStrLn $ "log\n" ++ intercalate "\n" _w+  return (ans',lp')  -- --------------------------------------------------------------------- -addLocaLDecl3 :: Changer-addLocaLDecl3 ans lp = do-  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")-  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns-+addLocaLDecl4 :: Changer+addLocaLDecl4 ans lp = do+  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+  Right (sigAnns, newSig)   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")+  -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp+  let       doAddLocal = do          tlDecs <- hsDecls lp          let parent = head tlDecs-         decls <- hsDecls parent-         balanceComments parent (head $ tail tlDecs) -         modifyAnnsT (setPrecedingLines newDecl 1 0)+         setPrecedingLinesT newSig  1 0+         setPrecedingLinesT newDecl 1 0 -         moveTrailingComments parent (last decls)-         parent' <- replaceDecls parent (decls++[newDecl])+         (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do+           return ((decls++[newSig,newDecl]),Nothing)+          replaceDecls lp (parent':tail tlDecs) +  let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal+  -- putStrLn $ "log\n" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++addLocaLDecl5 :: Changer+addLocaLDecl5 ans lp = do+  let+      doAddLocal = do+         [s1,d1,d2,d3] <- hsDecls lp++         transferEntryDPT d2 d3++         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do+           return ([d2],Nothing)+         replaceDecls lp [s1,d1',d3]+   let (lp',(ans',_),_w) = runTransform ans doAddLocal-  return (mergeAnnList [declAnns',ans'],lp')+  -- putStrLn $ "log\n" ++ intercalate "\n" _w+  return (ans',lp')  -- --------------------------------------------------------------------- +addLocaLDecl6 :: Changer+addLocaLDecl6 ans lp = do+  Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3")+  let declAnns' = setPrecedingLines newDecl 1 4 declAnns+      doAddLocal = do+        [d1,d2] <- hsDecls lp+        balanceComments d1 d2++        let GHC.L _ (GHC.ValD (GHC.FunBind  _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1+        balanceComments m1 m2++        (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do+           return ((newDecl : decls),Nothing)+        replaceDecls lp [d1', d2]++  let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal+  -- putStrLn $ "log:\n" ++ intercalate "\n" _w+  return (ans',lp')+-- ---------------------------------------------------------------------+ rmDecl1 :: Changer rmDecl1 ans lp = do   let doRmDecl = do          tlDecs <- hsDecls lp          let (d1:s1:d2:ds) = tlDecs -         -- First delete the decl only+         -- First delete the decl (d2) only+         balanceComments s1 d2 -- ++AZ++          balanceComments d2 (head ds)          lp1 <- replaceDecls lp (d1:s1:ds)+         -- return lp1           -- Then delete the sig separately          tlDecs1 <- hsDecls lp1          let (d1':s1':ds') = tlDecs1+         -- transferEntryDPT s1' (head ds')  -- required in HaRe.          balanceComments d1' s1'          balanceComments s1' (head ds')+         transferEntryDPT s1' (head ds')  -- required in HaRe.          replaceDecls lp (d1':ds')    let (lp',(ans',_),_w) = runTransform ans doRmDecl@@ -655,35 +735,118 @@   let       doRmDecl = do         let+          go :: GHC.LHsExpr GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName)+          go e@(GHC.L _ (GHC.HsLet{})) = do+            decs <- hsDecls e+            e' <- replaceDecls e (init decs)+            return e'+          go x = return x++        SYB.everywhereM (SYB.mkM go) lp++  let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:\n" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++rmDecl3 :: Changer+rmDecl3 ans lp = do+  let+      doRmDecl = do+         [d1,d2] <- hsDecls lp++         (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do+           setPrecedingLinesDeclT sd1 2 0+           return ([],Just sd1)++         replaceDecls lp [d1',sd1,d2]++  let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:\n" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++rmDecl4 :: Changer+rmDecl4 ans lp = do+  let+      doRmDecl = do+         [d1] <- hsDecls lp++         (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do+           -- [sd1,sd2] <- hsDecls d1+           transferEntryDPT sd1 sd2++           setPrecedingLinesDeclT sd1 2 0+           -- d1' <- replaceDecls d1 [sd2]+           return ([sd2],Just sd1)++         replaceDecls lp [d1',sd1]++  let (lp',(ans',_),_w) = runTransform ans doRmDecl+  return (ans',lp')++-- ---------------------------------------------------------------------++rmDecl5 :: Changer+rmDecl5 ans lp = do+  let+      doRmDecl = do+        let           go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)           go (GHC.HsLet lb expr) = do-            decs <- hsDecls lb-            lb' <- replaceDecls lb (init decs)+            decs <- hsDeclsValBinds lb+            let dec = last decs+            transferEntryDPT (head decs) dec+            lb' <- replaceDeclsValbinds lb [dec]             return (GHC.HsLet lb' expr)           go x = return x          SYB.everywhereM (SYB.mkM go) lp    let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:" ++ intercalate "\n" _w   return (ans',lp')  -- --------------------------------------------------------------------- -rmDecl3 :: Changer-rmDecl3 ans lp = do+rmDecl6 :: Changer+rmDecl6 ans lp = do   let       doRmDecl = do+         [d1] <- hsDecls lp++         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do+           let (ss1:_sd1:sd2:sds) = subDecs+           transferEntryDPT ss1 sd2++           return (sd2:sds,Nothing)++         replaceDecls lp [d1']++  let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++rmDecl7 :: Changer+rmDecl7 ans lp = do+  let+      doRmDecl = do          tlDecs <- hsDecls lp-         let [d1] = tlDecs+         let [s1,d1,d2,d3] = tlDecs -         subDecs <- hsDecls d1-         let [sd1] = subDecs+         balanceComments d1 d2+         balanceComments d2 d3 -         modifyAnnsT (setPrecedingLinesDecl sd1 2 0)-         d1' <- replaceDecls d1 []-         replaceDecls lp [d1',sd1]+         transferEntryDPT d2 d3 +         replaceDecls lp [s1,d1,d3]+   let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:" ++ intercalate "\n" _w   return (ans',lp')  -- ---------------------------------------------------------------------@@ -698,6 +861,86 @@          replaceDecls lp (s1':d1:d2)    let (lp',(ans',_),_w) = runTransform ans doRmDecl+  return (ans',lp')++-- ---------------------------------------------------------------------++rmTypeSig2 :: Changer+rmTypeSig2 ans lp = do+  let doRmDecl = do+         tlDecs <- hsDecls lp+         let [d1] = tlDecs++         (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do+           transferEntryDPT s d+           return ([d],Nothing)+         replaceDecls lp [d1']++  let (lp',(ans',_),_w) = runTransform ans doRmDecl+  -- putStrLn $ "log:" ++ intercalate "\n" _w+  return (ans',lp')++-- ---------------------------------------------------------------------++addHiding1 :: Changer+addHiding1 ans (GHC.L l p) = do+  let doTransform = do+        l0 <- uniqueSrcSpanT+        l1 <- uniqueSrcSpanT+        l2 <- uniqueSrcSpanT+        let+          [GHC.L li imp1,imp2] = GHC.hsmodImports p+          n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))+          n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))+          v1 = GHC.L l1 (GHC.IEVar n1)+          v2 = GHC.L l2 (GHC.IEVar n2)+          impHiding = GHC.L l0 [v1,v2]+          imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)}+          p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]}+        addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]+        addSimpleAnnT n1        (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))]+        addSimpleAnnT n2        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]+        return (GHC.L l p')++  let (lp',(ans',_),_w) = runTransform ans doTransform+  return (ans',lp')++-- ---------------------------------------------------------------------++addHiding2 :: Changer+addHiding2 ans (GHC.L l p) = do+  let doTransform = do+        l1 <- uniqueSrcSpanT+        l2 <- uniqueSrcSpanT+        let+          [GHC.L li imp1] = GHC.hsmodImports p+          Just (_,GHC.L lh ns) = GHC.ideclHiding imp1+          (GHC.L _ (GHC.IEVar ln)) = last ns+          n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))+          n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))+          v1 = GHC.L l1 (GHC.IEVar n1)+          v2 = GHC.L l2 (GHC.IEVar n2)+          imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))}+          p' = p { GHC.hsmodImports = [GHC.L li imp1']}+        addSimpleAnnT n1        (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))]+        addSimpleAnnT n2        (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]+        addTrailingCommaT ln+        return (GHC.L l p')++  let (lp',(ans',_),_w) = runTransform ans doTransform+  return (ans',lp')++-- ---------------------------------------------------------------------++cloneDecl1 :: Changer+cloneDecl1 ans lp = do+  let doChange = do+         tlDecs <- hsDecls lp+         let (d1:d2:ds) = tlDecs+         d2' <- fst <$> cloneT d2+         replaceDecls lp (d1:d2:d2':ds)++  let (lp',(ans',_),_w) = runTransform ans doChange   return (ans',lp')  -- ---------------------------------------------------------------------

@@ -0,0 +1,7 @@+module AddHiding1 where++import Data.Maybe++import Data.Maybe hiding (n1,n2)++f = 1

@@ -0,0 +1,7 @@+module AddHiding1 where++import Data.Maybe hiding (n1,n2)++import Data.Maybe hiding (n1,n2)++f = 1

@@ -0,0 +1,5 @@+module AddHiding2 where++import Data.Maybe hiding (f1,f2)++f = 1

@@ -0,0 +1,5 @@+module AddHiding2 where++import Data.Maybe hiding (f1,f2,n1,n2)++f = 1

@@ -0,0 +1,3 @@+module AddLocalDecl4 where++toplevel x = c * x

@@ -0,0 +1,6 @@+module AddLocalDecl4 where++toplevel x = c * x+  where+    nn :: Int+    nn = 2

@@ -0,0 +1,8 @@+module AddLocalDecl5 where++toplevel :: Integer -> Integer+toplevel x = c * x++-- c,d :: Integer+c = 7+d = 9

@@ -0,0 +1,9 @@+module AddLocalDecl5 where++toplevel :: Integer -> Integer+toplevel x = c * x+  where+    -- c,d :: Integer+    c = 7++d = 9

@@ -0,0 +1,9 @@+module AddLocalDecl6 where++foo [] = 1 -- comment 0+foo xs = 2 -- comment 1++bar [] = 1 -- comment 2+  where+    x = 3+bar xs = 2 -- comment 3

@@ -0,0 +1,11 @@+module AddLocalDecl6 where++foo [] = 1 -- comment 0+  where+    x = 3+foo xs = 2 -- comment 1++bar [] = 1 -- comment 2+  where+    x = 3+bar xs = 2 -- comment 3

@@ -0,0 +1,26 @@+{-# LANGUAGE BangPatterns, CPP, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, UnliftedFFITypes #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif+{-# OPTIONS_HADDOCK hide #-}++-- Flat unboxed arrays: instances++instance IArray UArray Bool where+    {-# INLINE bounds #-}+    bounds (UArray l u _ _) = (l,u)+    {-# INLINE numElements #-}+    numElements (UArray _ _ n _) = n+    {-# INLINE unsafeArray #-}+    unsafeArray lu ies = runST (unsafeArrayUArray lu ies False)+    {-# INLINE unsafeAt #-}+    unsafeAt (UArray _ _ _ arr#) (I# i#) =+        ((indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)+        `neWord#` int2Word# 0#)++    {-# INLINE unsafeReplace #-}+    unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)+    {-# INLINE unsafeAccum #-}+    unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)+    {-# INLINE unsafeAccumArray #-}+    unsafeAccumArray f initialValue lu ies = runST (unsafeAccumArrayUArray f initialValue lu ies)

@@ -0,0 +1,10 @@+module CloneDecl1 where++z = 3++foo a b =+  let+    x = a + b + z+    y = a * b - z+  in+    x + y

@@ -0,0 +1,17 @@+module CloneDecl1 where++z = 3++foo a b =+  let+    x = a + b + z+    y = a * b - z+  in+    x + y++foo a b =+  let+    x = a + b + z+    y = a * b - z+  in+    x + y

@@ -0,0 +1,110 @@++module GameData.Data where+#include "Utils.cpp"+import qualified Data.List as L+import qualified Data.List.Zipper as LZ+import Gamgine.Control (applyIf)+import qualified Gamgine.Zipper as GZ+import qualified GameData.Level as LV+import qualified GameData.Entity as E+IMPORT_LENS_AS_LE+++data Data = Data {+   levels :: LZ.Zipper LV.Level+   }++LENS(levels)++instance E.ApplyToEntity Data where+   eMap f = LE.modL currentLevelL (E.eMap f)+   eFilter p = LE.modL currentLevelL (E.eFilter p)+++currentLevelL    = currentLevelLens+currentLevelLens = LE.lens getCurrentLevel setCurrentLevel+   where+      getCurrentLevel       = LZ.cursor . levels+      setCurrentLevel level = LE.modL levelsL $ LZ.replace level+++newData :: [LV.Level] -> Data+newData = Data . LZ.fromList+++allLevels :: Data -> [LV.Level]+allLevels = LZ.toList . levels+++atLastLevel :: Data -> Bool+atLastLevel = GZ.atLast . levels+++atFirstLevel :: Data -> Bool+atFirstLevel = GZ.atFirst . levels+++levelFinished :: Data -> Bool+levelFinished = LV.allStarsCollected . LE.getL currentLevelL+++gameFinished :: Data -> Bool+gameFinished d = levelFinished d && atLastLevel d+++toNextLevel :: Data -> Data+toNextLevel d@Data {levels = lvs}+   | LZ.emptyp lvs || GZ.atLast lvs = d+   | otherwise =+      let lvs      = levels d+          (c', n') = LV.changeLevels (GZ.current lvs) (GZ.next lvs)+          in d {levels = LZ.replace n' . LZ.right . LZ.replace c' $ lvs}+++toPreviousLevel :: Data -> Data+toPreviousLevel d@Data {levels = lvs}+   | LZ.emptyp lvs || GZ.atFirst lvs = d+   | otherwise =+      let (c', p') = LV.changeLevels (GZ.current lvs) (GZ.previous lvs)+          in d {levels = LZ.replace p' . LZ.left . LZ.replace c' $ lvs}+++data AddLevel = BeforeCurrent | AfterCurrent | AfterLast++addEmptyLevel :: AddLevel -> Data -> Data+addEmptyLevel BeforeCurrent d@Data {levels = lvs} =+   let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel+       in d {levels = LZ.insert nlv' . LZ.replace c' $ lvs}++addEmptyLevel AfterCurrent d@Data {levels = lvs} =+   let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel+       in d {levels = LZ.insert nlv' . LZ.right . LZ.replace c' $ lvs}++addEmptyLevel AfterLast d@Data {levels = lvs} =+   let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel+       in d {levels = LZ.insert nlv' . LZ.end . LZ.replace c' $ lvs}+++data MoveLevel = Forward | Backward++moveCurrentLevel :: MoveLevel -> Data -> Data+moveCurrentLevel Forward d@Data {levels = lvs}+   | LZ.beginp lvs = d+   | otherwise     =+      let (p, c) = (GZ.previous lvs, GZ.current lvs)+          in d {levels = LZ.replace c . LZ.left . LZ.replace p $ lvs}++moveCurrentLevel Backward d@Data {levels = lvs}+   | GZ.atLast lvs = d+   | otherwise     =+      let (c, n) = (GZ.current lvs, GZ.next lvs)+          in d {levels = LZ.replace c . LZ.right . LZ.replace n $ lvs}+++removeCurrentLevel :: Data -> Data+removeCurrentLevel d@Data {levels = lvs}+   | GZ.atFirst lvs && GZ.atLast lvs =+      let (_, nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel+          in d {levels = LZ.replace nlv' lvs}++   | otherwise = d {levels = applyIf LZ.endp LZ.left . LZ.delete $ lvs}

@@ -0,0 +1,7 @@++forkOS_entry :: StablePtr (IO ()) -> IO ()+forkOS_entry stableAction = do+        action <- deRefStablePtr stableAction+        action++

@@ -0,0 +1,2 @@++i = \x -> x

@@ -0,0 +1,5 @@+module Main where++foo x = baz+  where foo = 2+        two = 4 where bax = 4

@@ -0,0 +1,1 @@+module Main where

@@ -0,0 +1,4 @@++foo' x = case (odd x) of+  True -> "Odd"+  False -> "Even"

@@ -0,0 +1,4 @@++joe x = case (odd x) of+  True -> "Odd"+  False -> "Even"

@@ -5,4 +5,5 @@   where     zz = 1 +foo = 3 -- EOF

@@ -5,4 +5,5 @@  zz = 1 +foo = 3 -- EOF

@@ -0,0 +1,9 @@+module RmDecl4 where++-- Remove first declaration from a where clause, last should still be indented+ff y = y + zz + xx+  where+    zz = 1+    xx = 2++-- EOF

@@ -0,0 +1,10 @@+module RmDecl4 where++-- Remove first declaration from a where clause, last should still be indented+ff y = y + zz + xx+  where+    xx = 2++zz = 1++-- EOF

@@ -0,0 +1,6 @@+module RmDecl5 where++sumSquares x y = let sq 0=0+                     sq z=z^pow+                     pow=2+                 in sq x + sq y

@@ -0,0 +1,4 @@+module RmDecl5 where++sumSquares x y = let pow=2+                 in sq x + sq y

@@ -0,0 +1,11 @@+module RmDecl6 where++foo a = baz+  where+    baz :: Int+    baz = x  + a++    x = 1++    y :: Int -> Int -> Int+    y a b = undefined

@@ -0,0 +1,8 @@+module RmDecl6 where++foo a = baz+  where+    x = 1++    y :: Int -> Int -> Int+    y a b = undefined

@@ -0,0 +1,8 @@+module RmDecl7 where++toplevel :: Integer -> Integer+toplevel x = c * x++-- c,d :: Integer+c = 7+d = 9

@@ -0,0 +1,6 @@+module RmDecl7 where++toplevel :: Integer -> Integer+toplevel x = c * x++d = 9

@@ -0,0 +1,7 @@+module RmTypeSig2 where++-- Pattern bind+tup@(h,t) = (1,ff)+  where+    ff :: Int+    ff = 15

@@ -0,0 +1,6 @@+module RmTypeSig2 where++-- Pattern bind+tup@(h,t) = (1,ff)+  where+    ff = 15

@@ -0,0 +1,133 @@+{-# INCLUDE "Parrot_hsc.h" #-}+{-# LINE 1 "Parrot.hsc" #-}+{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-full-laziness -fno-cse #-}+{-# LINE 2 "Parrot.hsc" #-}++{-# LINE 3 "Parrot.hsc" #-}++module Pugs.Embed.Parrot where+import Data.IORef+import System.Cmd+import System.Process+import System.Directory+import System.IO+import System.IO.Unsafe+import Data.Maybe+import Control.Monad+import Pugs.Compat (getEnv, _PUGS_HAVE_POSIX)+import Pugs.Internals (encodeUTF8)++findExecutable' :: String -> IO (Maybe FilePath)+findExecutable' cmd = do+    dir <- getEnv "PARROT_PATH"+    if isJust dir then (do+        rv  <- findExecutableInDirectory (fromJust dir) cmd+        if isJust rv then return rv else findExecutable'') else do+    findExecutable''+    where+    findExecutable'' = do+        rv  <- findExecutable cmd+        if isJust rv then return rv else do+        cwd <- getCurrentDirectory+        rv  <- findExecutableInDirectory cwd cmd+        if isJust rv then return rv else do+        return Nothing++findExecutableInDirectory :: FilePath -> FilePath -> IO (Maybe FilePath)+findExecutableInDirectory dir cmd = do+    let file | _PUGS_HAVE_POSIX = dir ++ ('/':cmd)+             | otherwise        = dir ++ ('\\':cmd) ++ ".exe"+    ok <- doesFileExist file+    return $ if ok then (Just file) else Nothing++findParrot :: IO FilePath+findParrot = do+    rv <- findExecutable' "parrot"+    case rv of+        Nothing     -> fail "Cannot find the parrot executable in PATH"+        Just cmd    -> return cmd++evalParrotFile :: FilePath -> IO ()+evalParrotFile file = do+    cmd <- findParrot+    -- parrot -j is fatal on systems where jit is not supported,+    -- so we use the next fastest CGP core.+    args <- getEnv "PUGS_PARROT_OPTS"+    let args' | isJust args && fromJust args /= "" = fromJust args+              | otherwise                          = "-f"+    rawSystem cmd [args', file]+    return ()++evalParrot :: String -> IO ()+evalParrot str = do+    tmp         <- getTemporaryDirectory+    (file, fh)  <- openTempFile tmp "pugs.pir"+    hPutStr fh str+    hClose fh+    evalParrotFile file+    removeFile file++evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String+evalPGE path match rule subrules = do+    (inp, out, err, pid) <- initPGE path+    (`mapM` subrules) $ \(name, rule) -> do+        let nameStr = escape name+            ruleStr = escape rule+        hPutStrLn inp $ unwords+            ["add_rule", show (length nameStr), show (length ruleStr)]+        hPutStrLn inp nameStr+        hPutStrLn inp ruleStr+    let matchStr = escape match+        ruleStr  = escape rule+    hPutStrLn inp $ unwords+        ["match", show (length matchStr), show (length ruleStr)]+    hPutStrLn inp $ matchStr+    hPutStrLn inp $ ruleStr+    hFlush inp+    rv <- hGetLine out+    case rv of+        ('O':'K':' ':sizeStr) -> do+            size <- readIO sizeStr+            rv   <- sequence (replicate size (hGetChar out))+            ln   <- hGetLine out+            return $ rv ++ ln+        _ -> do+            errMsg  <- hGetContents err+            rv      <- waitForProcess pid+            writeIORef _ParrotInterp Nothing+            let msg | null errMsg = show rv+                    | otherwise   = errMsg+            fail $ "*** Running external 'parrot' failed:\n" ++ msg+    where+    escape = escape . encodeUTF8+    _escape "" = ""+    _escape ('\\':xs) = "\\\\" ++ _escape xs+    _escape ('\n':xs) = "\\n" ++ _escape xs+    _escape (x:xs) = (x:_escape xs)++initPGE :: FilePath -> IO ParrotInterp+initPGE path = do+    rv <- readIORef _ParrotInterp+    case rv of+        Just interp@(_, _, _, pid) -> do+            gone <- getProcessExitCode pid+            if isNothing gone then return interp else do+            writeIORef _ParrotInterp Nothing+            initPGE path+        Nothing -> do+            cmd <- findParrot+            interp <- runInteractiveProcess cmd ["run_pge.pir"] (Just path) Nothing+            writeIORef _ParrotInterp (Just interp)+            return interp++type ParrotInterp = (Handle, Handle, Handle, ProcessHandle)++{-# NOINLINE _ParrotInterp #-}+_ParrotInterp :: IORef (Maybe ParrotInterp)+_ParrotInterp = unsafePerformIO $ newIORef Nothing++_DoCompile :: Maybe (IORef (String -> FilePath -> String -> IO String))+_DoCompile = Nothing+++{-# LINE 387 "Parrot.hsc" #-}

@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}++module UHC.Light.Compiler.CHR.Constraint+( Constraint (..)+, mkReduction+, cnstrReducablePart+, UnresolvedTrace (..)+, cnstrMpSingletonL, cnstrMpFromList+, ConstraintToInfoTraceMp+, cnstrTraceMpSingleton, cnstrTraceMpLiftTrace, cnstrTraceMpElimTrace, cnstrTraceMpFromList+, ConstraintToInfoMap+, emptyCnstrMp+, cnstrMpUnion, cnstrMpUnions+, cnstrRequiresSolve )+where+import UHC.Light.Compiler.Base.Common+import UHC.Light.Compiler.Ty+import UHC.Light.Compiler.CHR+import UHC.Light.Compiler.CHR.Key+import UHC.Light.Compiler.Base.TreeTrie+import UHC.Light.Compiler.Substitutable+import UHC.Util.Pretty as PP+import UHC.Util.Utils+import qualified Data.Set as Set+import qualified Data.Map as Map+import UHC.Light.Compiler.VarMp+import Control.Monad+import UHC.Util.Binary+import UHC.Util.Serialize+import Data.Typeable+import Data.Generics (Data)+import UHC.Light.Compiler.Opts.Base+++++{-# LINE 37 "src/ehc/CHR/Constraint.chs" #-}+-- | A Constraint is abstracted over the exact predicate, but differentiates on the role: to prove, can be assumed, and side effect of reduction+data Constraint p info+  = Prove           { cnstrPred :: !p }             -- proof obligation+  | Assume          { cnstrPred :: !p }             -- assumed constraint+  | Reduction                                       -- 'side effect', residual info used by (e.g.) codegeneration+                    { cnstrPred :: !p               -- the pred to which reduction was done+                    , cnstrInfo :: !info            -- additional reduction specific info w.r.t. codegeneration+                    , cnstrFromPreds :: ![p]        -- the preds from which reduction was done+                    , cnstrVarMp :: VarMp           -- additional bindings for type (etc.) variables, i.e. improving substitution+                    }+  deriving (Eq, Ord, Show)++{-# LINE 53 "src/ehc/CHR/Constraint.chs" #-}+mkReduction :: p -> info -> [p] -> Constraint p info+mkReduction p i ps+  = Reduction p i ps+              varlookupEmpty++{-# LINE 62 "src/ehc/CHR/Constraint.chs" #-}+#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable  Constraint+#else+deriving instance Typeable2 Constraint+#endif+deriving instance (Data x, Data y) => Data (Constraint x y)++{-# LINE 71 "src/ehc/CHR/Constraint.chs" #-}+-- | Dissection of Constraint, including reconstruction function+cnstrReducablePart :: Constraint p info -> Maybe (String,p,p->Constraint p info)+cnstrReducablePart (Prove  p) = Just ("Prf",p,Prove)+cnstrReducablePart (Assume p) = Just ("Ass",p,Assume)+cnstrReducablePart _          = Nothing++{-# LINE 84 "src/ehc/CHR/Constraint.chs" #-}+instance (CHRMatchable env p s) => CHRMatchable env (Constraint p info) s where+  chrMatchTo env s c1 c2+    = do { (_,p1,_) <- cnstrReducablePart c1+         ; (_,p2,_) <- cnstrReducablePart c2+         ; chrMatchTo env s p1 p2+         }++{-# LINE 93 "src/ehc/CHR/Constraint.chs" #-}+instance TTKeyable p => TTKeyable (Constraint p info) where+  toTTKey' o c -- = maybe [] (\(s,p,_) -> ttkAdd (TT1K_One $ Key_Str s) [toTTKey' o p]) $ cnstrReducablePart c+    = case cnstrReducablePart c of+        Just (s,p,_) -> ttkAdd' (TT1K_One $ Key_Str s) cs+                     where (_,cs) = toTTKeyParentChildren' o p+        _            -> panic "TTKeyable (Constraint p info).toTTKey'" -- ttkEmpty++{-# LINE 102 "src/ehc/CHR/Constraint.chs" #-}+instance (VarExtractable p v,VarExtractable info v) => VarExtractable (Constraint p info) v where+  varFreeSet c+    = case cnstrReducablePart c of+        Just (_,p,_) -> varFreeSet p+        _            -> Set.empty++instance (VarUpdatable p s,VarUpdatable info s) => VarUpdatable (Constraint p info) s where+  varUpd s      (Prove     p       ) = Prove      (varUpd s p)+  varUpd s      (Assume    p       ) = Assume     (varUpd s p)+  varUpd s      r@(Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})+                                     = r {cnstrPred=varUpd s p, cnstrInfo=varUpd s i, cnstrFromPreds=map (varUpd s) ps}++{-# LINE 120 "src/ehc/CHR/Constraint.chs" #-}+-- | The trace of an unresolved predicate+data UnresolvedTrace p info+  = UnresolvedTrace_None                                    -- no trace required when all is resolved+  | UnresolvedTrace_Red                                     -- ok reduction, with failure deeper down+      { utraceRedFrom       :: p+      , utraceInfoTo2From   :: info+      , utraceRedTo         :: [UnresolvedTrace p info]+      }+  | UnresolvedTrace_Fail                                    -- failed reduction+      { utraceRedFrom       :: p+      -- , utraceInfoTo2From    :: info+      , utraceRedTo         :: [UnresolvedTrace p info]+      }+  | UnresolvedTrace_Overlap                                 -- choice could not be made+      { utraceRedFrom       :: p+      , utraceRedChoices    :: [(info,[UnresolvedTrace p info])]+      }+  deriving Show++instance Eq p => Eq (UnresolvedTrace p info) where+  t1 == t2 = True -- utraceRedFrom t1 == utraceRedFrom t2++instance (PP p, PP info) => PP (UnresolvedTrace p info) where+  pp x = case x of+           UnresolvedTrace_None             -> PP.empty+           UnresolvedTrace_Red      p i us  -> p >|< ":" >#< i >-< indent 2 (vlist $ map pp us)+           UnresolvedTrace_Fail     p   us  -> p >|< ": FAIL" >-< indent 2 (vlist $ map pp us)+           UnresolvedTrace_Overlap  p uss   -> p >|< ": OVERLAP" >-< indent 2 (vlist $ map (\(i,u) -> i >-< indent 2 (vlist $ map pp u)) uss)++{-# LINE 155 "src/ehc/CHR/Constraint.chs" #-}+-- | Map from constraint to something+type ConstraintMp' p info x = Map.Map (Constraint p info) [x]++{-# LINE 160 "src/ehc/CHR/Constraint.chs" #-}+cnstrMpSingletonL :: Constraint p i -> [x] -> ConstraintMp' p i x+cnstrMpSingletonL c xs = Map.singleton c xs++cnstrMpSingleton :: Constraint p i -> x -> ConstraintMp' p i x+cnstrMpSingleton c x = cnstrMpSingletonL c [x]++cnstrMpFromList :: (Ord p, Ord i) => [(Constraint p i,x)] -> ConstraintMp' p i x+cnstrMpFromList l = Map.fromListWith (++) [ (c,[x]) | (c,x) <- l ]++cnstrMpMap :: (Ord p, Ord i) => (x -> y) -> ConstraintMp' p i x -> ConstraintMp' p i y+cnstrMpMap f = Map.map (map f)++{-# LINE 174 "src/ehc/CHR/Constraint.chs" #-}+-- | Map from constraint to info + trace+type ConstraintToInfoTraceMp p info = ConstraintMp' p info (info,[UnresolvedTrace p info])++{-# LINE 179 "src/ehc/CHR/Constraint.chs" #-}+cnstrTraceMpFromList :: (Ord p, Ord i) => [(Constraint p i,(i,[UnresolvedTrace p i]))] -> ConstraintToInfoTraceMp p i+cnstrTraceMpFromList = cnstrMpFromList++cnstrTraceMpSingleton :: Constraint p i -> i -> [UnresolvedTrace p i] -> ConstraintToInfoTraceMp p i+cnstrTraceMpSingleton c i ts = cnstrMpSingleton c (i,ts)++cnstrTraceMpElimTrace :: (Ord p, Ord i) => ConstraintToInfoTraceMp p i -> ConstraintToInfoMap p i+cnstrTraceMpElimTrace = cnstrMpMap fst++cnstrTraceMpLiftTrace :: (Ord p, Ord i) => ConstraintToInfoMap p i -> ConstraintToInfoTraceMp p i+cnstrTraceMpLiftTrace = cnstrMpMap (\x -> (x,[]))++{-# LINE 193 "src/ehc/CHR/Constraint.chs" #-}+-- | Map from constraint to info+type ConstraintToInfoMap     p info = ConstraintMp' p info info++{-# LINE 198 "src/ehc/CHR/Constraint.chs" #-}+emptyCnstrMp :: ConstraintMp' p info x+emptyCnstrMp = Map.empty++{-# LINE 208 "src/ehc/CHR/Constraint.chs" #-}+cnstrMpUnion :: (Ord p, Ord i) => ConstraintMp' p i x -> ConstraintMp' p i x -> ConstraintMp' p i x+cnstrMpUnion = Map.unionWith (++)++cnstrMpUnions :: (Ord p, Ord i) => [ConstraintMp' p i x] -> ConstraintMp' p i x+cnstrMpUnions = Map.unionsWith (++)++{-# LINE 220 "src/ehc/CHR/Constraint.chs" #-}+-- | Predicate for whether solving is required+cnstrRequiresSolve :: Constraint p info -> Bool+cnstrRequiresSolve (Reduction {}) = False+cnstrRequiresSolve _              = True++{-# LINE 231 "src/ehc/CHR/Constraint.chs" #-}+instance (PP p, PP info) => PP (Constraint p info) where+  pp (Prove     p     ) = "Prove"  >#< p+  pp (Assume    p     ) = "Assume" >#< p+  pp (Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})+                        = "Red"    >#< p >#< "<" >#< i >#< "<" >#< ppBracketsCommas ps++{-# LINE 243 "src/ehc/CHR/Constraint.chs" #-}+instance (Serialize p, Serialize i) => Serialize (Constraint p i) where+  sput (Prove     a      ) = sputWord8 0 >> sput a+  sput (Assume    a      ) = sputWord8 1 >> sput a+  sput (Reduction a b c d) = sputWord8 2 >> sput a >> sput b >> sput c >> sput d+  sget = do t <- sgetWord8+            case t of+              0 -> liftM  Prove     sget+              1 -> liftM  Assume    sget+              2 -> liftM4 Reduction sget sget sget sget+

@@ -0,0 +1,4 @@++foo = do+  let    x = 1 -- a comment+  return x

@@ -0,0 +1,12 @@+module TypeSignature where++{- Lifting baz to the top level should bring in xx and a as parameters,+   and update the signature to include these+-}+foo a = (baz xx a)+  where+    xx :: Int -> Int -> Int+    xx p1 p2 = p1 + p2++baz :: (Int -> Int -> Int) -> Int ->Int+baz xx a = xx 1 a