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 - [email protected]
+
+- 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
