haskell-tools-prettyprint 0.6.0.0 → 0.7.0.0

raw patch · 7 files changed

+79/−55 lines, 7 filesdep ~haskell-tools-astPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-tools-ast

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/PrettyPrint.hs +9/−4
• Language/Haskell/Tools/Transform.hs +4/−4
• Language/Haskell/Tools/Transform/FixCPPSpans.hs +0/−31
• Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs +42/−7
• Language/Haskell/Tools/Transform/SourceTemplate.hs +21/−5
• Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs +1/−1
• haskell-tools-prettyprint.cabal +2/−3

@@ -5,7 +5,7 @@            #-}
 
 -- | Pretty printing the AST
-module Language.Haskell.Tools.PrettyPrint (prettyPrint) where
+module Language.Haskell.Tools.PrettyPrint (prettyPrint, toRoseTree) where
 
 import FastString (fsLit)
 import SrcLoc
@@ -15,10 +15,12 @@ import Language.Haskell.Tools.Transform.SourceTemplate
 
 import Control.Monad.State
+import Control.Reference
 import Data.Foldable (Foldable(..), concat)
 import Data.List as List
 import Data.List.Split (splitOn)
 import Data.Sequence hiding (null, replicate)
+import Debug.Trace
 
 -- | Pretty prints an AST by using source templates stored as node info
 prettyPrint :: (SourceInfoTraversal node) => node dom SrcTemplateStage -> String
@@ -37,7 +39,8 @@ printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children)
   = do slide <- calculateSlide rng
        let printTemplateElems :: [SourceTemplateElem] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char)
-           printTemplateElems (TextElem txt : rest) children = putString slide min txt >+< printTemplateElems rest children
+           printTemplateElems (TextElem txtElems _ : rest) children = putString slide min txt >+< printTemplateElems rest children
+             where txt = concatMap (^. sourceTemplateText) txtElems
            printTemplateElems (ChildElem : rest) (child : children) = printRose' parent child >+< printTemplateElems rest children
            printTemplateElems [] [] = return empty
            printTemplateElems _ [] = error $ "More child elem in template than actual children (elems: " ++ show elems ++ ", children: " ++ show children ++ ")"
@@ -55,8 +58,10 @@          putString slide min bef
            >+< (maybe printListWithSeps printListWithSepsIndented indented) actRng slide min actualSeps children
            >+< putString slide min aft
-  where actualSeps = case seps of [] -> repeat defSep
-                                  _  -> seps ++ repeat (last seps)
+  where stringSeps :: [String]
+        stringSeps = map (concatMap (^. sourceTemplateText)) (map fst seps)
+        actualSeps = case stringSeps of [] -> repeat defSep
+                                        _  -> stringSeps ++ repeat (last stringSeps)
 
 printRose' _ (RoseTree (RoseOptional (SourceTemplateOpt {})) []) = return empty
 printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child])

@@ -9,14 +9,14 @@   , sourceTemplateNodeRange, sourceTemplateNodeElems
   , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators
   , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter
+  , SourceTemplateElem(..), sourceTemplateTextElem, sourceTemplateTextRange, SourceTemplateTextElem(..), sourceTemplateText, isStayingText
   -- parts of the transformation, used for debugging purposes
-  , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices, fixMainRange, fixCPPSpans
+  , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices, fixMainRange, extractStayingElems
   ) where
 
-import Language.Haskell.Tools.Transform.FixCPPSpans (fixCPPSpans)
 import Language.Haskell.Tools.Transform.PlaceComments (getNormalComments, getPragmaComments, placeComments)
 import Language.Haskell.Tools.Transform.RangeTemplate ()
-import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices)
+import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices, extractStayingElems)
 import Language.Haskell.Tools.Transform.RangeToRangeTemplate (cutUpRanges, fixRanges)
 import Language.Haskell.Tools.Transform.SourceTemplate
 import Language.Haskell.Tools.Transform.SourceTemplateHelpers
@@ -31,7 +31,7 @@ prepareAST srcBuffer = rangeToSource srcBuffer . cutUpRanges . fixRanges
 
 prepareASTCpp :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage
-prepareASTCpp srcBuffer = fixCPPSpans . rangeToSource srcBuffer . cutUpRanges . fixRanges . fixMainRange srcBuffer
+prepareASTCpp srcBuffer = extractStayingElems . rangeToSource srcBuffer . cutUpRanges . fixRanges . fixMainRange srcBuffer
 
 fixMainRange :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom RangeStage
 fixMainRange buffer mod = setRange (mkSrcSpan (srcSpanStart $ getRange mod) (RealSrcLoc (endPos startPos buffer))) mod

@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
-module Language.Haskell.Tools.Transform.FixCPPSpans where
-
-import Control.Monad.State
-import Control.Reference
-import qualified Data.Text as Txt
-
-import Language.Haskell.Tools.AST
-import Language.Haskell.Tools.Transform.SourceTemplate (SourceTemplateElem(..), sourceTemplateNodeElems, srcTmpSeparators)
-
-fixCPPSpans :: Ann UModule dom SrcTemplateStage -> Ann UModule dom SrcTemplateStage
--- the state will be used to pass the removed separators to the correct child
-fixCPPSpans = flip evalState [] . (sourceInfoTraverseDown (SourceInfoTrf trfElem trfList pure) (modify ([]:)) (modify tail))
-  where trfList ls = do ret <- srcTmpSeparators&traversal !~ removeClosing $ ls
-                        modify $ (\(act:rest) -> ("" : act ++ [""]):rest)
-                        return ret
-        trfElem elem = do st <- get
-                          case st of
-                            -- add the moved element to the end
-                            []:(bef:aft:rest):stack -> do
-                              put $ []:rest:stack
-                              return $ sourceTemplateNodeElems .- ((TextElem bef :) . (++ [TextElem aft])) $ elem
-                            _ -> return elem
-
-        removeClosing :: String -> State [[String]] String
-        removeClosing sep = let (aftPrev,rest) = Txt.breakOnEnd "#endif" (Txt.pack sep)
-                                (remaining,befNext) = Txt.breakOn "#if" (rest)
-                             in if Txt.null aftPrev || Txt.null befNext
-                                  then do modify (\(act:rest) -> (act ++ [Txt.unpack aftPrev, Txt.unpack befNext]) : rest)
-                                          return $ Txt.unpack remaining
-                                  else return sep

@@ -5,17 +5,21 @@ -- Basically it reads the source file and attaches parts of the source file to the AST elements that have the range of the given source code fragment.
 module Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate where
 
+import Control.Monad.Identity
 import Control.Monad.State
-import Control.Reference ((^.), _1)
+import Control.Reference
 import Data.Map as Map
 import Data.Ord (Ord(..), Ordering(..))
 import Data.Set as Set
+import Data.List
+import Data.List.Split
 import FastString (mkFastString)
 import Language.Haskell.Tools.AST
 import Language.Haskell.Tools.Transform.RangeTemplate
 import Language.Haskell.Tools.Transform.SourceTemplate
 import SrcLoc
 import StringBuffer (StringBuffer, nextChar, atEnd)
+import Debug.Trace
 
 rangeToSource :: SourceInfoTraversal node => StringBuffer -> Ann node dom RngTemplateStage
                                                           -> Ann node dom SrcTemplateStage
@@ -57,14 +61,45 @@ applyFragments srcs = flip evalState srcs
   . sourceInfoTraverseDown (SourceInfoTrf
      (\ni -> do template <- mapM getTextFor (ni ^. rngTemplateNodeElems)
-                return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) template 0 Nothing)
+                return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) (concat template) 0 Nothing)
      (\(RangeTemplateList rng bef aft sep indented seps)
          -> do (own, rest) <- splitAt (length seps) <$> get
                put rest
-               return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented own 0 Nothing))
+               return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented (Prelude.zip (Prelude.map ((:[]) . NormalText) own) (Prelude.map RealSrcSpan seps)) 0 Nothing))
      (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 0 Nothing)))
      (return ()) (return ())
-  where getTextFor RangeChildElem = return ChildElem
-        getTextFor (RangeElem _) = do (src:rest) <- get
-                                      put rest
-                                      return (TextElem src)
+  where getTextFor RangeChildElem = return [ChildElem]
+        getTextFor (RangeElem rng) = do (src:rest) <- get
+                                        put rest
+                                        return [TextElem [NormalText src] (RealSrcSpan rng)]
+
+-- | Marks template elements in the AST that should always be present in the source code, regardless of their
+-- containing elements being deleted.
+-- Currently it recognizes CPP pragmas (lines starting with #)
+-- This function should only be applied to an AST if CPP is enabled.
+extractStayingElems :: SourceInfoTraversal node => Ann node dom SrcTemplateStage -> Ann node dom SrcTemplateStage
+extractStayingElems = runIdentity . sourceInfoTraverse (SourceInfoTrf
+    (sourceTemplateNodeElems & traversal & sourceTemplateTextElem !- breakStaying)
+    (srcTmpSeparators & traversal & _1 !- breakStaying)
+    pure)
+
+    where -- splits the elements into separate lines and then recombines them
+          breakStaying :: [SourceTemplateTextElem] -> [SourceTemplateTextElem]
+          breakStaying = concat . Prelude.map (\(NormalText s) -> toTxtElems s)
+
+          toTxtElems :: String -> [SourceTemplateTextElem]
+          toTxtElems = extractStaying . splitOn "\n"
+          extractStaying lines = Prelude.foldr appendTxt []
+                                   $ Prelude.map (\ln -> if "#" `isPrefixOf` ln then StayingText ln "\n" else NormalText ln) lines
+          -- recombines the lines if they are both normal text
+          -- otherwise it moves the windows '\r' characters to the correct position
+          appendTxt (NormalText n1) (NormalText n2 : rest) = NormalText (n1 ++ '\n':n2) : rest
+          appendTxt e (next@NormalText{} : ls) = case reverse (e ^. sourceTemplateText) of
+                                              -- fix '\r' characters that are separated from '\n'
+                                    '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : (sourceTemplateText .- ("\r\n" ++) $ next) : ls
+                                    _      -> e : (sourceTemplateText .- ('\n':) $ next) : ls
+          appendTxt e (next : ls) = case reverse (e ^. sourceTemplateText) of
+                                              -- fix '\r' characters that are separated from '\n'
+                                    '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : NormalText "\r\n" : next : ls
+                                    _      -> e : NormalText "\n" : next : ls
+          appendTxt e [] = [e]

@@ -28,7 +28,7 @@                               , _srcTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated
                               , _srcTmpDefaultSeparator :: String -- ^ The default separator if the list were empty
                               , _srcTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned
-                              , _srcTmpSeparators :: [String] -- ^ The actual separators that were found in the source code
+                              , _srcTmpSeparators :: [([SourceTemplateTextElem], SrcSpan)] -- ^ The actual separators that were found in the source code
                               , _srcTmpListMinInd :: Int -- ^ Minimum indentation for the element
                               , _srcTmpListRelPos :: Maybe Int -- ^ Relative indentation for newly created elements
                               }
@@ -73,7 +73,7 @@ srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) (Maybe [Bool])
 srcTmpIndented = lens _srcTmpIndented (\v s -> s { _srcTmpIndented = v })
 
-srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [String]
+srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [([SourceTemplateTextElem], SrcSpan)]
 srcTmpSeparators = lens _srcTmpSeparators (\v s -> s { _srcTmpSeparators = v })
 
 srcTmpListMinimalIndent :: Simple Lens (ListInfo SrcTemplateStage) Int
@@ -102,11 +102,23 @@ 
 -- | An element of a source template for a singleton AST node.
 data SourceTemplateElem
-  = TextElem { _sourceTemplateText :: String } -- ^ Source text belonging to the current node
+  = TextElem { _sourceTemplateTextElem :: [SourceTemplateTextElem]
+             , _sourceTemplateTextRange :: SrcSpan
+             } -- ^ Source text belonging to the current node
   | ChildElem -- ^ Placeholder for the next children of the node
      deriving (Eq, Ord, Data)
 
+isStayingText :: SourceTemplateTextElem -> Bool
+isStayingText StayingText{} = True
+isStayingText _ = False
+
+data SourceTemplateTextElem
+  = NormalText { _sourceTemplateText :: String }
+  | StayingText { _sourceTemplateText :: String, _lineEndings :: String }
+     deriving (Eq, Ord, Data)
+
 makeReferences ''SourceTemplateElem
+makeReferences ''SourceTemplateTextElem
 
 instance HasRange (SpanInfo SrcTemplateStage) where
   getRange = (^. sourceTemplateNodeRange)
@@ -123,10 +135,14 @@ instance Show (SpanInfo SrcTemplateStage) where
   show (SourceTemplateNode _ sp _ _) = concatMap show sp
 instance Show (ListInfo SrcTemplateStage) where
-  show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ "*>"
+  show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ " " ++ show _srcTmpSeparators ++ "*>"
 instance Show (OptionalInfo SrcTemplateStage) where
   show SourceTemplateOpt{..} = "<?" ++ show _srcTmpOptBefore ++ " " ++ show _srcTmpOptAfter ++ "?>"
 
 instance Show SourceTemplateElem where
-  show (TextElem s) = s
+  show (TextElem s _) = show s
   show ChildElem = "<.>"
+
+instance Show SourceTemplateTextElem where
+  show (NormalText s) = show s
+  show (StayingText s _) = "|" ++ show s ++ "|"

@@ -16,7 +16,7 @@ type ASTMulti node dom = AnnListG node dom SrcTemplateStage
 
 instance IsString (SpanInfo SrcTemplateStage) where
-  fromString s = SourceTemplateNode noSrcSpan [TextElem s] 0 Nothing
+  fromString s = SourceTemplateNode noSrcSpan [TextElem [NormalText s] noSrcSpan] 0 Nothing
 
 -- * Basic elements
 child :: SpanInfo SrcTemplateStage

@@ -1,5 +1,5 @@ name:                haskell-tools-prettyprint
-version:             0.6.0.0
+version:             0.7.0.0
 synopsis:            Pretty printing of Haskell-Tools AST
 description:         Converts the Haskell-Tools AST to text. Prepares the AST for this conversion. If the AST was created from the GHC AST this pretty printing will result in the original source code. Generated AST parts will get the default formatting. Works using the source annotations that are present in the AST. Creates a rose tree first to simplify the conversion.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -23,7 +23,6 @@                      , Language.Haskell.Tools.Transform.SourceTemplate
                      , Language.Haskell.Tools.Transform.SourceTemplateHelpers
                      , Language.Haskell.Tools.Transform.PlaceComments
-                     , Language.Haskell.Tools.Transform.FixCPPSpans
   build-depends:       base              >= 4.9  && < 4.10
                      , mtl               >= 2.2  && < 2.3
                      , containers        >= 0.5  && < 0.6
@@ -32,5 +31,5 @@                      , split             >= 0.2  && < 0.3
                      , text              >= 1.2  && < 1.3
                      , ghc               >= 8.0  && < 8.1
-                     , haskell-tools-ast >= 0.6  && < 0.7
+                     , haskell-tools-ast >= 0.7  && < 0.8
   default-language: Haskell2010