commit ghc-haskell-tools-prettyprint for openSUSE:Factory

Hello community, here is the log from the commit of package ghc-haskell-tools-prettyprint for openSUSE:Factory checked in at 2017-08-31 20:56:06 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-prettyprint" Thu Aug 31 20:56:06 2017 rev:2 rq:513374 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint/ghc-haskell-tools-prettyprint.changes 2017-04-12 18:06:46.450064168 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new/ghc-haskell-tools-prettyprint.changes 2017-08-31 20:56:07.286300144 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:13 UTC 2017 - psimons@suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-prettyprint-0.5.0.0.tar.gz New: ---- haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-prettyprint.spec ++++++ --- /var/tmp/diff_new_pack.UgMxUS/_old 2017-08-31 20:56:08.066190567 +0200 +++ /var/tmp/diff_new_pack.UgMxUS/_new 2017-08-31 20:56:08.070190006 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-prettyprint Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Pretty printing of Haskell-Tools AST License: BSD-3-Clause @@ -33,6 +33,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-text-devel BuildRequires: ghc-uniplate-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ haskell-tools-prettyprint-0.5.0.0.tar.gz -> haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-05-17 18:59:17.000000000 +0200 @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances , FlexibleContexts , UndecidableInstances - , NamedFieldPuns + , NamedFieldPuns #-} -- | 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,16 +15,18 @@ 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 prettyPrint = toList . printRose . toRoseTree -printRose :: RoseTree SrcTemplateStage -> Seq Char +printRose :: RoseTree SrcTemplateStage -> Seq Char printRose rt = evalState (printRose' startLoc rt) startLoc where startLoc = mkRealSrcLoc (fsLit "") 1 1 @@ -34,10 +36,11 @@ printRose' :: RealSrcLoc -> RoseTree SrcTemplateStage -> PPState (Seq Char) -- simple implementation could be optimized a bit -- warning: the length of the file should not exceed maxbound::Int -printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children) +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 ++ ")" @@ -46,81 +49,87 @@ min = minInd `max` getPosByRelative parent relInd printTemplateElems elems children - + printRose' _ (RoseTree (RoseList (SourceTemplateList {})) []) = return empty -printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) +printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd - putString slide min bef - >+< (if indented then printListWithSepsIndented else printListWithSeps) actRng slide min actualSeps children + 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]) +printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child]) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd putString slide min bef >+< printRose' actRng child >+< putString slide min aft printRose' _ (RoseTree (RoseOptional _) _) = error "More than one child element in an optional node." - + getPosByRelative :: RealSrcLoc -> Maybe Int -> Int getPosByRelative sp (Just i) = srcLocCol sp + i - 1 getPosByRelative _ _ = 0 calculateSlide :: SrcSpan -> PPState Int -calculateSlide (RealSrcSpan originalSpan) = do +calculateSlide (RealSrcSpan originalSpan) = do actualSpan <- get return $ srcLocCol actualSpan - srcLocCol (realSrcSpanStart originalSpan) calculateSlide _ = return 0 putString :: Int -> Int -> String -> PPState (Seq Char) -putString slide minInd s +putString slide minInd s = do modify $ advanceStr newStr return (fromList newStr) where start:rest = splitOn "\n" s newStr = concat $ intersperse ("\n" ++ replicate slide ' ') (start : map (extendToNSpaces minInd) rest) extendToNSpaces n str = replicate n ' ' ++ (List.dropWhile (== ' ') $ List.take n str) ++ List.drop n str - + advanceStr :: String -> RealSrcLoc -> RealSrcLoc advanceStr s loc = foldl advanceSrcLoc loc s untilReaches :: String -> RealSrcLoc -> RealSrcLoc -> (String, Int) -untilReaches s start end - = let ls = splitOn "\n" s - in case ls of _:_:_ -> (unlines (init ls) ++) - `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end - _ -> (s, srcLocCol start) +untilReaches s start end + = let ls = splitOn "\n" s + in case ls of _:_:_ -> (unlines (init ls) ++) + `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end + _ -> (s, srcLocCol $ foldl advanceSrcLoc start s) where untilReaches' [] curr _ = ([], srcLocCol curr) untilReaches' (c:rest) curr until | srcLocCol advancedLoc <= srcLocCol until = (c:) `mapFst` untilReaches' rest advancedLoc until where advancedLoc = advanceSrcLoc curr c untilReaches' _ curr _ = ([], srcLocCol curr) - + mapFst :: (a -> b) -> (a, x) -> (b, x) mapFst f (a, x) = (f a, x) (>+<) :: PPState (Seq Char) -> PPState (Seq Char) -> PPState (Seq Char) (>+<) = liftM2 (><) - + printListWithSeps :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps = printListWithSeps' putString +printListWithSeps = printListWithSeps' (const putString) 0 -- | Prints the elements of a list where the elements must be printed in the same line (do stmts, case alts, let binds, ...) -printListWithSepsIndented :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSepsIndented parent slide minInd seps children +printListWithSepsIndented :: [Bool] -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSepsIndented indentedChildren parent slide minInd seps children = do base <- get - let putCorrectSep _ min s = do curr <- get - let (shortened, currCol) = untilReaches s curr base - putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' - printListWithSeps' putCorrectSep parent slide minInd seps children - -printListWithSeps' :: (Int -> Int -> String -> PPState (Seq Char)) -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps' _ _ _ _ _ [] = return empty -printListWithSeps' _ parent _ _ _ [child] = printRose' parent child -printListWithSeps' putCorrectSep parent slide minInd (sep:seps) (child:children) - = printRose' parent child >+< putCorrectSep slide minInd sep >+< printListWithSeps' putCorrectSep parent slide minInd seps children -printListWithSeps' _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" + let putCorrectSep i _ min s | isIndented i + = do curr <- get + let (shortened, currCol) = untilReaches s curr base + putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' + putCorrectSep _ slide minInd s = putString slide minInd s + printListWithSeps' putCorrectSep 0 parent slide minInd seps children + where -- the ith separator is before the ith element + isIndented i = case List.drop i indentedChildren of False:_ -> False; _ -> True + +printListWithSeps' :: (Int -> Int -> Int -> String -> PPState (Seq Char)) -> Int -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSeps' _ _ _ _ _ _ [] = return empty +printListWithSeps' _ _ parent _ _ _ [child] = printRose' parent child +printListWithSeps' putCorrectSep i parent slide minInd (sep:seps) (child:children) + = printRose' parent child >+< putCorrectSep i slide minInd sep >+< printListWithSeps' putCorrectSep (i+1) parent slide minInd seps children +printListWithSeps' _ _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-06-05 18:15:07.000000000 +0200 @@ -1,68 +1,78 @@ {-# LANGUAGE ScopedTypeVariables - , FlexibleContexts - , LambdaCase + , FlexibleContexts + , LambdaCase #-} -- | This transformation expands nodes to contain the comments that should be attached to them. After this, a -- normalizing transformation should be performed that expands parents to contain their children. module Language.Haskell.Tools.Transform.PlaceComments where +import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Reference hiding (element) import Data.Char (isSpace, isAlphaNum) import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe -import qualified Data.Set as Set (lookupLE, lookupGE, fromList) +import qualified Data.Set as Set +import Data.Set (Set) -import ApiAnnotation (AnnotationComment(..)) +import ApiAnnotation (ApiAnnKey, AnnotationComment(..)) import SrcLoc import Language.Haskell.Tools.AST -getNormalComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] +getNormalComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] getNormalComments = Map.map (filter (not . isPragma . unLoc)) -getPragmaComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] -getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) - $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms +getPragmaComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] +getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) + $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms where getPragmaCommand = takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile isSpace . drop 3 isPragma :: AnnotationComment -> Bool isPragma (AnnBlockComment str) = take 3 str == "{-#" && take 3 (reverse str) == "}-#" isPragma _ = False --- | Puts comments in the nodes they should be attached to. Leaves the AST in a state where parent nodes --- does not contain all of their children. -placeComments :: RangeInfo stage => Map.Map SrcSpan [Located AnnotationComment] - -> Ann UModule dom stage - -> Ann UModule dom stage -placeComments comms mod - = resizeAnnots (concatMap (map nextSrcLoc . snd) (Map.toList comms)) mod +-- | Puts comments in the nodes they should be attached to. Watches for lexical tokens +-- that may divide the comment and the supposed element. +-- Leaves the AST in a state where parent nodes does not contain all of their children. +placeComments :: RangeInfo stage => Map ApiAnnKey [SrcSpan] -> Map.Map SrcSpan [Located AnnotationComment] + -> Ann UModule dom stage -> Ann UModule dom stage +placeComments tokens comms mod + = resizeAnnots (Set.filter (\rng -> srcSpanStart rng /= srcSpanEnd rng) $ Set.fromList $ concat (Map.elems tokens)) + (concatMap (map nextSrcLoc . snd) (Map.toList cleanedComments)) mod where spans = allElemSpans mod sortedElemStarts = Set.fromList $ map srcSpanStart spans sortedElemEnds = Set.fromList $ map srcSpanEnd spans - nextSrcLoc comm@(L sp _) + nextSrcLoc comm@(L sp _) = let after = fromMaybe noSrcLoc (Set.lookupLE (srcSpanStart sp) sortedElemEnds) before = fromMaybe noSrcLoc (Set.lookupGE (srcSpanEnd sp) sortedElemStarts) in ((after,before),comm) - + cleanedComments = Map.map (map cleanComment) comms + cleanComment (L loc (AnnLineComment txt)) + | last txt `elem` "\n\r" = L (mkSrcSpan (srcSpanStart loc) (decreaseCol (srcSpanEnd loc))) (AnnLineComment (init txt)) + cleanComment c = c + decreaseCol (RealSrcLoc l) = mkSrcLoc (srcLocFile l) (srcLocLine l) (srcLocCol l - 1) + decreaseCol l = l + allElemSpans :: (SourceInfoTraversal node, RangeInfo stage) => Ann node dom stage -> [SrcSpan] allElemSpans = execWriter . sourceInfoTraverse (SourceInfoTrf (\ni -> tell [ni ^. nodeSpan] >> pure ni) pure pure) - -resizeAnnots :: RangeInfo stage => [((SrcLoc, SrcLoc), Located AnnotationComment)] + +resizeAnnots :: RangeInfo stage => Set SrcSpan -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> Ann UModule dom stage -> Ann UModule dom stage -resizeAnnots comments elem - = flip evalState comments $ - -- if a comment that could be attached to more than one documentable element (possibly nested) +resizeAnnots tokens comments elem + = flip evalState comments $ flip runReaderT tokens $ + -- if a comment that could be attached to more than one documentable element (possibly nested) -- the order of different documentable elements here decide which will be chosen - + modImports&annList !~ expandAnnot -- expand imports to cover their comments >=> modDecl&annList !~ expandTopLevelDecl -- expand declarations to cover their comments >=> expandAnnot -- expand the module itself to cover its comments $ elem -type ExpandType elem dom stage = Ann elem dom stage -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] (Ann elem dom stage) +type ExpandType elem dom stage = Ann elem dom stage -> ReaderT (Set SrcSpan) (State [((SrcLoc, SrcLoc), Located AnnotationComment)]) (Ann elem dom stage) expandTopLevelDecl :: RangeInfo stage => ExpandType UDecl dom stage expandTopLevelDecl @@ -84,14 +94,14 @@ expandValueBind :: RangeInfo stage => ExpandType UValueBind dom stage expandValueBind - = valBindLocals & annJust & localBinds & annList !~ expandLocalBind + = valBindLocals & annJust & localBinds & annList !~ expandLocalBind >=> funBindMatches & annList & matchBinds & annJust & localBinds & annList !~ expandLocalBind >=> expandAnnot expandLocalBind :: RangeInfo stage => ExpandType ULocalBind dom stage expandLocalBind - = localVal !~ expandValueBind - >=> localSig !~ expandTypeSig + = localVal !~ expandValueBind + >=> localSig !~ expandTypeSig >=> expandAnnot expandConDecl :: RangeInfo stage => ExpandType UConDecl dom stage @@ -106,48 +116,56 @@ expandAnnot :: forall elem dom stage . RangeInfo stage => ExpandType elem dom stage expandAnnot elem = do let Just sp = elem ^? annotation&sourceInfo&nodeSpan - applicable <- gets (applicableComments (srcSpanStart sp) (srcSpanEnd sp)) - + tokens <- ask + applicable <- lift $ gets (applicableComments tokens (srcSpanStart sp) (srcSpanEnd sp)) + -- this check is just for performance (quick return if no modification is needed) if not (null applicable) then do -- the new span is the original plus all the covered spans - let newSp@(RealSrcSpan newSpan) + let newSp@(RealSrcSpan newSpan) = foldl combineSrcSpans (fromJust $ elem ^? nodeSp) (map (getLoc . snd) applicable) -- take out all comments that are now covered - modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) + lift $ modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) return $ nodeSp .= newSp $ elem else return elem where nodeSp :: Simple Partial (Ann elem dom stage) SrcSpan nodeSp = annotation&sourceInfo&nodeSpan - --- This classification does not prefer inline comments to previous line comments, this is implicitely done + +-- This classification does not prefer inline comments to previous line comments, this is implicitly done -- by the order in which the elements are traversed. -applicableComments :: SrcLoc -> SrcLoc - -> [((SrcLoc, SrcLoc), Located AnnotationComment)] +applicableComments :: Set SrcSpan -> SrcLoc -> SrcLoc + -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -applicableComments start end = filter applicableComment +applicableComments tokens start end = filter applicableComment where -- A comment that starts with | binds to the next documented element - applicableComment ((_, before), L _ comm) - | isCommentOnNext comm = before == start + applicableComment ((_, before), L sp comm) + | isCommentOnNext comm = before == start && noTokenBetween (srcSpanEnd sp) start -- A comment that starts with ^ binds to the previous documented element - applicableComment ((after, _), L _ comm) - | isCommentOnPrev comm = after == end + applicableComment ((after, _), L sp comm) + | isCommentOnPrev comm = after == end && noTokenBetween end (srcSpanStart sp) -- All other comment binds to the previous definition if it is on the same line - applicableComment ((after, _), L (RealSrcSpan loc) _) + applicableComment ((after, _), L sp@(RealSrcSpan loc) _) | after == end && srcLocLine (realSrcSpanStart loc) == getLineLocDefault end = True + && noTokenBetween end (srcSpanStart sp) -- or the next one if that is on the next line and the columns line up - applicableComment ((_, before), L (RealSrcSpan loc) _) + applicableComment ((_, before), L sp@(RealSrcSpan loc) _) | before == start && srcLocLine (realSrcSpanEnd loc) + 1 == getLineLocDefault start && srcLocCol (realSrcSpanStart loc) == getLineColDefault start + && noTokenBetween (srcSpanEnd sp) start = True applicableComment _ = False - + getLineLocDefault (RealSrcLoc l) = srcLocLine l getLineLocDefault _ = -1 getLineColDefault (RealSrcLoc l) = srcLocCol l getLineColDefault _ = -1 + noTokenBetween start end + = case Set.lookupGE (srcLocSpan start) tokens of + Just tok -> srcSpanStart tok >= end + Nothing -> True + -- * GHC mistakenly parses -- ^ and -- | comments as simple line comments. -- These functions check if a given comment is attached to the previous or next comment. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -15,14 +15,14 @@ instance SourceInfo RngTemplateStage where data SpanInfo RngTemplateStage = RangeTemplateNode { _rngTemplateNodeRange :: RealSrcSpan - , _rngTemplateNodeElems :: [RangeTemplateElem] + , _rngTemplateNodeElems :: [RangeTemplateElem] } deriving Data data ListInfo RngTemplateStage = RangeTemplateList { _rngTemplateListRange :: RealSrcSpan , _rngTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _rngTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated , _rngTmpDefaultSeparator :: String -- ^ The default separator if the list were empty - , _rngTmpIndented :: Bool -- ^ True, if the elements need to be aligned in the same column + , _rngTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned , _rngTmpSeparators :: [RealSrcSpan] -- ^ The actual separators that were found in the source code } deriving Data @@ -51,7 +51,7 @@ rngTmpDefaultSeparator :: Simple Lens (ListInfo RngTemplateStage) String rngTmpDefaultSeparator = lens _rngTmpDefaultSeparator (\v s -> s { _rngTmpDefaultSeparator = v }) -rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) Bool +rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) (Maybe [Bool]) rngTmpIndented = lens _rngTmpIndented (\v s -> s { _rngTmpIndented = v }) rngTmpSeparators :: Simple Lens (ListInfo RngTemplateStage) [RealSrcSpan] @@ -75,19 +75,19 @@ getRangeElemSpan (RangeElem sp) = Just sp getRangeElemSpan _ = Nothing -instance HasRange (SpanInfo RngTemplateStage) where +instance HasRange (SpanInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateNodeRange) setRange (RealSrcSpan sp) = rngTemplateNodeRange .= sp setRange _ = id -instance HasRange (ListInfo RngTemplateStage) where - getRange = RealSrcSpan . (^. rngTemplateListRange) - setRange (RealSrcSpan sp) = rngTemplateListRange .= sp +instance HasRange (ListInfo RngTemplateStage) where + getRange = RealSrcSpan . (^. rngTemplateListRange) + setRange (RealSrcSpan sp) = rngTemplateListRange .= sp setRange _ = id -instance HasRange (OptionalInfo RngTemplateStage) where +instance HasRange (OptionalInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateOptRange) - setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp + setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp setRange _ = id instance Show (SpanInfo RngTemplateStage) where @@ -96,7 +96,7 @@ show RangeTemplateList{..} = "<*" ++ shortShowSpan (RealSrcSpan _rngTemplateListRange) ++ " " ++ show _rngTmpListBefore ++ " " ++ show _rngTmpDefaultSeparator ++ " " ++ show _rngTmpListAfter ++ "*>" instance Show (OptionalInfo RngTemplateStage) where show RangeTemplateOpt{..} = "<?" ++ shortShowSpan (RealSrcSpan _rngTemplateOptRange) ++ " " ++ show _rngTmpOptBefore ++ " " ++ show _rngTmpOptAfter ++ "?>" - + instance Show RangeTemplateElem where show (RangeElem sp) = shortShowSpan (RealSrcSpan sp) show RangeChildElem = "<.>" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-05-24 19:51:13.000000000 +0200 @@ -1,65 +1,107 @@ -{-# LANGUAGE LambdaCase +{-# LANGUAGE LambdaCase , FlexibleContexts #-} --- | This module converts range templates into source templates. +-- | This module converts range templates into source templates. -- 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 ((^.)) -import Data.Map +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 rangeToSource srcInput tree = let locIndices = getLocIndices tree srcMap = mapLocIndices srcInput locIndices - in applyFragments (elems srcMap) tree + in applyFragments (Map.elems srcMap) tree -- maps could be strict -- | Assigns an index (in the order they are used) for each range -getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Map OrdSrcSpan Int -getLocIndices = snd . flip execState (0, empty) . - sourceInfoTraverseDown (SourceInfoTrf +getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Set (RealSrcLoc, Int) +getLocIndices = snd . flip execState (0, Set.empty) . + sourceInfoTraverseDown (SourceInfoTrf (\ni -> do { mapM_ (\el -> case getRangeElemSpan el of Just sp -> modify (insertElem sp); _ -> return ()) (ni ^. rngTemplateNodeElems); return ni }) (\ni -> do { mapM_ (modify . insertElem) (ni ^. rngTmpSeparators); return ni }) - pure ) + pure ) (return ()) (return ()) - where insertElem sp (i,m) = (i+1, insert (OrdSrcSpan sp) i m) - - + where insertElem sp (i,m) = (i+1, Set.insert (realSrcSpanEnd sp, i) m) + -- | Partitions the source file in the order where the parts are used in the AST -mapLocIndices :: Ord k => StringBuffer -> Map OrdSrcSpan k -> Map k String -mapLocIndices inp = fst . foldlWithKey (\(new, str) sp k -> let (rem, val) = takeSpan str sp - in (insert k (reverse val) new, rem)) (empty, inp) - where takeSpan :: StringBuffer -> OrdSrcSpan -> (StringBuffer, String) - takeSpan str (OrdSrcSpan sp) = takeSpan' (realSrcSpanStart sp) (realSrcSpanEnd sp) (str,"") - takeSpan _ (NoOrdSrcSpan {}) = error "takeSpan: missing source span" - - takeSpan' :: RealSrcLoc -> RealSrcLoc -> (StringBuffer, String) -> (StringBuffer, String) - takeSpan' start end (sb, taken) | start < end && not (atEnd sb) - = let (c,rem) = nextChar sb in takeSpan' (advanceSrcLoc start c) end (rem, c:taken) - takeSpan' _ _ (rem, taken) = (rem, taken) - +mapLocIndices :: Ord k => StringBuffer -> Set (RealSrcLoc, k) -> Map k String +mapLocIndices inp = (^. _1) . Set.foldl (\(new, str, pos) (sp, k) -> let (rem, val, newPos) = takeSpan str pos sp + in (Map.insert k (reverse val) new, rem, newPos)) + (Map.empty, inp, mkRealSrcLoc (mkFastString "") 1 1) + where takeSpan :: StringBuffer -> RealSrcLoc -> RealSrcLoc -> (StringBuffer, String, RealSrcLoc) + takeSpan str pos end = takeSpan' end (str,"", pos) + + takeSpan' :: RealSrcLoc -> (StringBuffer, String, RealSrcLoc) -> (StringBuffer, String, RealSrcLoc) + takeSpan' end (sb, taken, pos) | (srcLocLine pos `compare` srcLocLine end) `thenCmp` (srcLocCol pos `compare` srcLocCol end) == LT && not (atEnd sb) + = let (c,rem) = nextChar sb in takeSpan' end (rem, c:taken, advanceSrcLoc pos c) + takeSpan' _ (rem, taken, pos) = (rem, taken, pos) + + thenCmp EQ o2 = o2 + thenCmp o1 _ = o1 + -- | Replaces the ranges in the AST with the source file parts applyFragments :: SourceInfoTraversal node => [String] -> Ann node dom RngTemplateStage -> Ann node dom SrcTemplateStage applyFragments srcs = flip evalState srcs . sourceInfoTraverseDown (SourceInfoTrf (\ni -> do template <- mapM getTextFor (ni ^. rngTemplateNodeElems) - return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) template 0 Nothing) - (\(RangeTemplateList rng bef aft sep indented seps) - -> do (own, rest) <- splitAt (length seps) <$> get + 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)) - (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 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) \ No newline at end of file + 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 str = extractStaying $ splitOn "\n" $ str + where + extractStaying lines | not (any ("#" `isPrefixOf`) lines) = [NormalText str] + 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] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-06-14 16:16:01.000000000 +0200 @@ -11,7 +11,7 @@ import Control.Monad.State import Control.Reference ((^.)) import Data.List -import Data.Maybe (Maybe(..), maybe, mapMaybe) +import Data.Maybe (Maybe(..), mapMaybe) import FastString as GHC (unpackFS) import SrcLoc @@ -20,17 +20,17 @@ -- | Creates a source template from the ranges and the input file. -- All source ranges must be good ranges. -cutUpRanges :: forall node dom . SourceInfoTraversal node +cutUpRanges :: forall node dom . SourceInfoTraversal node => Ann node dom NormRangeStage -> Ann node dom RngTemplateStage cutUpRanges n = evalState (cutUpRanges' n) [[],[]] where cutUpRanges' :: Ann node dom NormRangeStage -> State [[SrcSpan]] (Ann node dom RngTemplateStage) cutUpRanges' = sourceInfoTraverseUp (SourceInfoTrf (trf cutOutElemSpan) (trf cutOutElemList) (trf cutOutElemOpt)) desc asc - + -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + -- combine the current node with its children, and add it to the list of current nodes trf :: HasRange (x RngTemplateStage) => ([SrcSpan] -> x NormRangeStage -> x RngTemplateStage) -> x NormRangeStage -> State [[SrcSpan]] (x RngTemplateStage) @@ -44,12 +44,12 @@ cutOutElemSpan sps (NormNodeInfo (RealSrcSpan sp)) = RangeTemplateNode sp $ foldl breakFirstHit (foldl breakFirstHit [RangeElem sp] loc) span where (loc,span) = partition (\sp -> srcSpanStart sp == srcSpanEnd sp) sps - breakFirstHit (elem:rest) sp + breakFirstHit (elem:rest) sp = case breakUpRangeElem elem sp of -- only continue if the correct place for the child range is not found Just pieces -> pieces ++ rest Nothing -> elem : breakFirstHit rest sp - breakFirstHit [] sp = error ("breakFirstHit: " ++ maybe "" unpackFS (srcSpanFileName_maybe sp) ++ " didn't find correct place for " ++ shortShowSpan sp ++ " in " ++ shortShowSpan sp ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") + breakFirstHit [] inner = error ("breakFirstHit: " ++ unpackFS (srcSpanFile sp) ++ " didn't find correct place for " ++ shortShowSpan inner ++ " in " ++ shortShowSpan (RealSrcSpan sp) ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") cutOutElemSpan _ (NormNodeInfo (UnhelpfulSpan {})) = error "cutOutElemSpan: no real span" cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage @@ -63,9 +63,9 @@ = mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems) -- at least two elements needed or there can be no separators getSeparators _ _ = [] - + cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage -cutOutElemOpt sps (NormOptInfo bef aft sp) +cutOutElemOpt sps (NormOptInfo bef aft sp) = let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps in RangeTemplateOpt wholeRange bef aft @@ -73,49 +73,49 @@ -- if it is inside the range of the template element. Returns Nothing if the second argument is not inside. breakUpRangeElem :: RangeTemplateElem -> SrcSpan -> Maybe [RangeTemplateElem] breakUpRangeElem (RangeElem outer) (RealSrcSpan inner) - | outer `containsSpan` inner - = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) + | outer `containsSpan` inner + = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) then [ RangeElem (mkRealSrcSpan (realSrcSpanStart outer) (realSrcSpanStart inner)) ] else []) ++ [ RangeChildElem ] ++ - (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) + (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) then [ RangeElem (mkRealSrcSpan (realSrcSpanEnd inner) (realSrcSpanEnd outer)) ] else []) breakUpRangeElem _ _ = Nothing -- | Modifies ranges to contain their children -fixRanges :: SourceInfoTraversal node - => Ann node dom RangeStage +fixRanges :: SourceInfoTraversal node + => Ann node dom RangeStage -> Ann node dom NormRangeStage fixRanges node = evalState (sourceInfoTraverseUp (SourceInfoTrf (trf expandToContain) (trf expandListToContain) (trf expandOptToContain)) desc asc node) [[],[]] where -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + trf :: HasRange (x NormRangeStage) => ([SrcSpan] -> x RangeStage -> x NormRangeStage) -> x RangeStage -> State [[SrcSpan]] (x NormRangeStage) trf f ni = do (below : top : xs) <- get let res = f below ni resRange = getRange res endOfSiblings = srcSpanEnd (collectSpanRanges (srcSpanStart resRange) top) - correctedRange = if endOfSiblings > srcSpanStart resRange - then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) + correctedRange = if endOfSiblings > srcSpanStart resRange + then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) else resRange put ([] : (top ++ [ correctedRange ]) : xs) return $ setRange correctedRange res -- | Expand a simple node to contain its children expandToContain :: [SrcSpan] -> SpanInfo RangeStage -> SpanInfo NormRangeStage -expandToContain cont (NodeSpan sp) +expandToContain cont (NodeSpan sp) = NormNodeInfo (checkSpans cont $ foldl1 combineSrcSpans $ sp : cont) expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage -expandListToContain cont (ListPos bef aft def ind sp) +expandListToContain cont (ListPos bef aft def ind sp) = NormListInfo bef aft def ind (checkSpans cont $ collectSpanRanges sp cont) expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage -expandOptToContain cont (OptionalPos bef aft sp) +expandOptToContain cont (OptionalPos bef aft sp) = NormOptInfo bef aft (checkSpans cont $ collectSpanRanges sp cont) collectSpanRanges :: SrcLoc -> [SrcSpan] -> SrcSpan @@ -124,8 +124,7 @@ -- | Checks the contained source ranges to detect the convertion problems where we can see their location. checkSpans :: [SrcSpan] -> SrcSpan -> SrcSpan -checkSpans spans res - = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res +checkSpans spans res + = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res then error $ "Wrong src spans in " ++ show res else res - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -5,7 +5,7 @@ , RecordWildCards , TypeFamilies #-} --- | The final version of the source annotation. Each node contains its original textual format, with the places of +-- | The final version of the source annotation. Each node contains its original textual format, with the places of -- the children specified by placeholders. module Language.Haskell.Tools.Transform.SourceTemplate where @@ -15,25 +15,25 @@ import SrcLoc instance SourceInfo SrcTemplateStage where - data SpanInfo SrcTemplateStage + data SpanInfo SrcTemplateStage = SourceTemplateNode { _sourceTemplateNodeRange :: SrcSpan -- ^ The (original) range of the given element , _sourceTemplateNodeElems :: [SourceTemplateElem] -- ^ The children of the given node, could be text or child nodes , _srcTmpMinInd :: Int -- ^ Minimum indentation for the element , _srcTmpRelPos :: Maybe Int -- ^ Relative indentation for newly created elements } deriving (Eq, Ord, Data) - data ListInfo SrcTemplateStage + data ListInfo SrcTemplateStage = SourceTemplateList { _sourceTemplateListRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _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 :: Bool -- ^ True, if the elements need to be aligned in the same column - , _srcTmpSeparators :: [String] -- ^ The actual separators that were found in the source code + , _srcTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned + , _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 } deriving (Eq, Ord, Data) - data OptionalInfo SrcTemplateStage + data OptionalInfo SrcTemplateStage = SourceTemplateOpt { _sourceTemplateOptRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpOptBefore :: String -- ^ Text that should be put before the element if it appears , _srcTmpOptAfter :: String -- ^ Text that should be put after the element if it appears @@ -70,10 +70,10 @@ srcTmpDefaultSeparator :: Simple Lens (ListInfo SrcTemplateStage) String srcTmpDefaultSeparator = lens _srcTmpDefaultSeparator (\v s -> s { _srcTmpDefaultSeparator = v }) -srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) Bool +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 @@ -95,39 +95,54 @@ srcTmpOptMinimalIndent :: Simple Lens (OptionalInfo SrcTemplateStage) Int srcTmpOptMinimalIndent = lens _srcTmpOptMinInd (\v s -> s { _srcTmpOptMinInd = v }) - + srcTmpOptRelPos :: Simple Lens (OptionalInfo SrcTemplateStage) (Maybe Int) srcTmpOptRelPos = lens _srcTmpOptRelPos (\v s -> s { _srcTmpOptRelPos = v }) - + -- | 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) - setRange = (sourceTemplateNodeRange .=) - -instance HasRange (ListInfo SrcTemplateStage) where - getRange = (^. sourceTemplateListRange) - setRange = (sourceTemplateListRange .=) - -instance HasRange (OptionalInfo SrcTemplateStage) where +instance HasRange (SpanInfo SrcTemplateStage) where + getRange = (^. sourceTemplateNodeRange) + setRange = (sourceTemplateNodeRange .=) + +instance HasRange (ListInfo SrcTemplateStage) where + getRange = (^. sourceTemplateListRange) + setRange = (sourceTemplateListRange .=) + +instance HasRange (OptionalInfo SrcTemplateStage) where getRange = (^. sourceTemplateOptRange) - setRange = (sourceTemplateOptRange .=) - + setRange = (sourceTemplateOptRange .=) + 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 ++ "|" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-05-03 22:13:56.000000000 +0200 @@ -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 @@ -26,7 +26,7 @@ opt = SourceTemplateOpt noSrcSpan "" "" 0 Nothing list :: ListInfo SrcTemplateStage -list = SourceTemplateList noSrcSpan "" "" "" False [] 0 Nothing +list = SourceTemplateList noSrcSpan "" "" "" Nothing [] 0 Nothing -- * Modifiers @@ -77,7 +77,7 @@ -- | The elements of the list should be indented on the same column indented :: ListInfo SrcTemplateStage -> ListInfo SrcTemplateStage -indented = (srcTmpIndented .= True) . (srcTmpDefaultSeparator .= "\n") +indented = (srcTmpIndented .= Just []) . (srcTmpDefaultSeparator .= "\n") -- | Concatenates two source templates to produce a new template with all child elements. (<>) :: SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs 2017-05-24 22:37:50.000000000 +0200 @@ -1,6 +1,6 @@ -- | A module for preparing the representation of the AST for pretty printing. module Language.Haskell.Tools.Transform - ( prepareAST + ( prepareAST, prepareASTCpp -- comment handling , placeComments, getNormalComments, getPragmaComments -- generating source templates @@ -9,20 +9,32 @@ , sourceTemplateNodeRange, sourceTemplateNodeElems , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + , SourceTemplateElem(..), sourceTemplateTextElem, sourceTemplateTextRange, SourceTemplateTextElem(..), sourceTemplateText, lineEndings, isStayingText -- parts of the transformation, used for debugging purposes - , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices + , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices, fixMainRange, extractStayingElems ) where 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 +import FastString (mkFastString) import Language.Haskell.Tools.AST -import StringBuffer (StringBuffer) +import SrcLoc +import StringBuffer (StringBuffer, nextChar, atEnd) -- | Prepares the AST for pretty printing -prepareAST :: SourceInfoTraversal node => StringBuffer -> Ann node dom RangeStage -> Ann node dom SrcTemplateStage +prepareAST :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage prepareAST srcBuffer = rangeToSource srcBuffer . cutUpRanges . fixRanges + +prepareASTCpp :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage +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 + where startPos = mkRealSrcLoc (mkFastString "") 1 1 + endPos pos buf | atEnd buf = pos + endPos pos buf = let (ch,buf') = nextChar buf in endPos (advanceSrcLoc pos ch) buf' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal --- old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal 2017-01-31 20:55:48.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-prettyprint -version: 0.5.0.0 +version: 0.8.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 @@ -12,7 +12,7 @@ cabal-version: >=1.10 library - ghc-options: -O2 + ghc-options: -O2 exposed-modules: Language.Haskell.Tools.PrettyPrint , Language.Haskell.Tools.Transform , Language.Haskell.Tools.IndentationUtils @@ -29,6 +29,7 @@ , references >= 0.3 && < 0.4 , uniplate >= 1.6 && < 1.7 , split >= 0.2 && < 0.3 + , text >= 1.2 && < 1.3 , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , haskell-tools-ast >= 0.8 && < 0.9 + default-language: Haskell2010