haskell-tools-prettyprint 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+681/−13 lines, 9 filesdep +uniplatedep −haskell-tools-ast-trfdep ~basedep ~haskell-tools-astdep ~referencesPVP ok

version bump matches the API change (PVP)

Dependencies added: uniplate

Dependencies removed: haskell-tools-ast-trf

Dependency ranges changed: base, haskell-tools-ast, references, split

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/PrettyPrint.hs +1/−1
• Language/Haskell/Tools/Transform.hs +29/−0
• Language/Haskell/Tools/Transform/PlaceComments.hs +175/−0
• Language/Haskell/Tools/Transform/RangeTemplate.hs +102/−0
• Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs +68/−0
• Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs +124/−0
• Language/Haskell/Tools/Transform/SourceTemplate.hs +102/−0
• Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs +61/−0
• haskell-tools-prettyprint.cabal +19/−12

@@ -12,7 +12,7 @@ 
 import Language.Haskell.Tools.AST
 import Language.Haskell.Tools.PrettyPrint.RoseTree
-import Language.Haskell.Tools.AnnTrf.SourceTemplate
+import Language.Haskell.Tools.Transform.SourceTemplate
 
 import Control.Monad.State
 import Control.Reference

@@ -0,0 +1,29 @@+-- | A module for preparing the representation of the AST for pretty printing.
+module Language.Haskell.Tools.Transform
+  ( prepareAST
+  -- comment handling
+  , placeComments, getNormalComments, getPragmaComments
+  -- generating source templates
+  , child, opt, optBefore, optAfter, list, indentedList, indentedListBefore, indentedListAfter, listSep
+  , listSepBefore, listSepAfter, listSepBeforeAfter, (<>)
+  -- references on source templates
+  , sourceTemplateNodeRange, sourceTemplateNodeElems
+  , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators
+  , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter
+  -- parts of the transformation, used for debugging purposes
+  , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices
+  ) where
+
+import Language.Haskell.Tools.Transform.RangeToRangeTemplate
+import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate
+import Language.Haskell.Tools.Transform.RangeTemplate
+import Language.Haskell.Tools.Transform.SourceTemplate
+import Language.Haskell.Tools.Transform.SourceTemplateHelpers
+import Language.Haskell.Tools.Transform.PlaceComments
+
+import Language.Haskell.Tools.AST
+import StringBuffer
+
+-- | Prepares the AST for pretty printing
+prepareAST :: SourceInfoTraversal node => StringBuffer -> Ann node dom RangeStage -> Ann node dom SrcTemplateStage
+prepareAST srcBuffer = rangeToSource srcBuffer . cutUpRanges . fixRanges

@@ -0,0 +1,175 @@+{-# LANGUAGE ScopedTypeVariables
+           , 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 qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe
+import Data.List
+import Data.Char (isSpace, isAlphaNum)
+import Data.Data
+import Data.Generics.Uniplate.Data
+import Control.Reference hiding (element)
+import Control.Monad.Writer
+import Control.Monad.State
+
+import SrcLoc
+import ApiAnnotation
+import Outputable
+import Debug.Trace
+
+import Language.Haskell.Tools.AST
+
+getNormalComments :: Map.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 
+  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
+  where spans = allElemSpans mod
+        sortedElemStarts = Set.fromList $ map srcSpanStart spans
+        sortedElemEnds = Set.fromList $ map srcSpanEnd spans
+        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)
+  
+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)]
+              -> 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) 
+        -- 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)
+
+expandTopLevelDecl :: RangeInfo stage => ExpandType UDecl dom stage
+expandTopLevelDecl
+  = declBody & annJust & cbElements & annList !~ expandClsElement
+      >=> declCons & annList !~ expandConDecl
+      >=> declGadt & annList !~ expandGadtConDecl
+      >=> declTypeSig !~ expandTypeSig
+      >=> expandAnnot
+
+expandTypeSig :: RangeInfo stage => ExpandType UTypeSignature dom stage
+expandTypeSig
+  = tsType & typeParams !~ expandAnnot >=> expandAnnot
+
+expandClsElement :: RangeInfo stage => ExpandType UClassElement dom stage
+expandClsElement
+  = ceTypeSig !~ expandTypeSig
+      >=> ceBind !~ expandValueBind
+      >=> expandAnnot
+
+expandValueBind :: RangeInfo stage => ExpandType UValueBind dom stage
+expandValueBind
+  = 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 
+      >=> expandAnnot
+
+expandConDecl :: RangeInfo stage => ExpandType UConDecl dom stage
+expandConDecl
+  = conDeclFields & annList !~ expandAnnot >=> expandAnnot
+
+expandGadtConDecl :: RangeInfo stage => ExpandType UGadtConDecl dom stage
+expandGadtConDecl
+  = gadtConType & gadtConRecordFields & annList !~ expandAnnot >=> expandAnnot
+
+-- | Expands tree elements to contain the comments that should be attached to them.
+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))
+       
+       -- 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) 
+               = 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))
+         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
+-- by the order in which the elements are traversed.
+applicableComments :: SrcLoc -> SrcLoc 
+                   -> [((SrcLoc, SrcLoc), Located AnnotationComment)] 
+                   -> [((SrcLoc, SrcLoc), Located AnnotationComment)]
+applicableComments start end = filter applicableComment
+  where -- A comment that starts with | binds to the next documented element
+        applicableComment ((_, before), L _ comm) 
+          | isCommentOnNext comm = before == start
+        -- A comment that starts with ^ binds to the previous documented element
+        applicableComment ((after, _), L _ comm) 
+          | isCommentOnPrev comm = after == end
+        -- All other comment binds to the previous definition if it is on the same line
+        applicableComment ((after, _), L (RealSrcSpan loc) _) 
+          | after == end && srcLocLine (realSrcSpanStart loc) == getLineLocDefault end = True
+        -- or the next one if that is on the next line and the columns line up
+        applicableComment ((_, before), L (RealSrcSpan loc) _) 
+          | before == start && srcLocLine (realSrcSpanEnd loc) + 1 == getLineLocDefault start
+                            && srcLocCol (realSrcSpanStart loc) == getLineColDefault start
+          = True
+        applicableComment _ = False
+        
+        getLineLocDefault (RealSrcLoc l) = srcLocLine l
+        getLineLocDefault _              = -1
+
+        getLineColDefault (RealSrcLoc l) = srcLocCol l
+        getLineColDefault _              = -1
+
+-- * GHC mistakenly parses -- ^ and -- | comments as simple line comments.
+-- These functions check if a given comment is attached to the previous or next comment.
+
+-- | Checks if a doc comment belongs to the next definition.
+isCommentOnNext :: AnnotationComment -> Bool
+isCommentOnNext (AnnDocCommentNext _) = True
+isCommentOnNext (AnnLineComment s) = firstNonspaceCharIs '|' s
+isCommentOnNext (AnnBlockComment s) = firstNonspaceCharIs '|' s
+isCommentOnNext _ = False
+
+-- | Checks if a doc comment belongs to the previous definition.
+isCommentOnPrev :: AnnotationComment -> Bool
+isCommentOnPrev (AnnDocCommentPrev _) = True
+isCommentOnPrev (AnnLineComment s) = firstNonspaceCharIs '^' s
+isCommentOnPrev (AnnBlockComment s) = firstNonspaceCharIs '^' s
+isCommentOnPrev _ = False
+
+-- the comment string contains the -- or {- characters
+firstNonspaceCharIs :: Char -> String -> Bool
+firstNonspaceCharIs c s = Just c == listToMaybe (dropWhile isSpace (drop 2 s))

@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell
+           , DeriveDataTypeable
+           , RecordWildCards
+           , TypeFamilies
+           , FlexibleInstances
+           #-}
+-- | The range template is an intermediate annotation level, where the children nodes of the tree
+-- had been cut from the parent nodes, but the annotations still contain ranges instead of text.
+module Language.Haskell.Tools.Transform.RangeTemplate where
+
+import Data.Data
+import Control.Reference
+import SrcLoc
+import Language.Haskell.Tools.AST
+
+instance SourceInfo RngTemplateStage where
+  data SpanInfo RngTemplateStage = RangeTemplateNode { _rngTemplateNodeRange :: RealSrcSpan
+                                                     , _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
+                                                     , _rngTmpSeparators :: [RealSrcSpan] -- ^ The actual separators that were found in the source code
+                                                     }
+    deriving Data
+  data OptionalInfo RngTemplateStage = RangeTemplateOpt { _rngTemplateOptRange :: RealSrcSpan
+                                                        , _rngTmpOptBefore :: String -- ^ Text that should be put before the element if it appears
+                                                        , _rngTmpOptAfter :: String -- ^ Text that should be put after the element if it appears
+                                                        }
+    deriving Data
+
+
+rngTemplateNodeRange :: Simple Lens (SpanInfo RngTemplateStage) RealSrcSpan
+rngTemplateNodeRange = lens _rngTemplateNodeRange (\v s -> s { _rngTemplateNodeRange = v })
+
+rngTemplateNodeElems :: Simple Lens (SpanInfo RngTemplateStage) [RangeTemplateElem]
+rngTemplateNodeElems = lens _rngTemplateNodeElems (\v s -> s { _rngTemplateNodeElems = v })
+
+rngTemplateListRange :: Simple Lens (ListInfo RngTemplateStage) RealSrcSpan
+rngTemplateListRange = lens _rngTemplateListRange (\v s -> s { _rngTemplateListRange = v })
+
+rngTmpListBefore :: Simple Lens (ListInfo RngTemplateStage) String
+rngTmpListBefore = lens _rngTmpListBefore (\v s -> s { _rngTmpListBefore = v })
+
+rngTmpListAfter :: Simple Lens (ListInfo RngTemplateStage) String
+rngTmpListAfter = lens _rngTmpListAfter (\v s -> s { _rngTmpListAfter = v })
+
+rngTmpDefaultSeparator :: Simple Lens (ListInfo RngTemplateStage) String
+rngTmpDefaultSeparator = lens _rngTmpDefaultSeparator (\v s -> s { _rngTmpDefaultSeparator = v })
+
+rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) Bool
+rngTmpIndented = lens _rngTmpIndented (\v s -> s { _rngTmpIndented = v })
+
+rngTmpSeparators :: Simple Lens (ListInfo RngTemplateStage) [RealSrcSpan]
+rngTmpSeparators = lens _rngTmpSeparators (\v s -> s { _rngTmpSeparators = v })
+
+rngTemplateOptRange :: Simple Lens (OptionalInfo RngTemplateStage) RealSrcSpan
+rngTemplateOptRange = lens _rngTemplateOptRange (\v s -> s { _rngTemplateOptRange = v })
+
+rngTmpOptBefore :: Simple Lens (OptionalInfo RngTemplateStage) String
+rngTmpOptBefore = lens _rngTmpOptBefore (\v s -> s { _rngTmpOptBefore = v })
+
+rngTmpOptAfter :: Simple Lens (OptionalInfo RngTemplateStage) String
+rngTmpOptAfter = lens _rngTmpOptAfter (\v s -> s { _rngTmpOptAfter = v })
+
+-- | An element of a range template for a singleton AST node.
+data RangeTemplateElem = RangeElem RealSrcSpan -- ^ A range for the source code of the element
+                       | RangeChildElem        -- ^ The place for a child element
+                       deriving Data
+
+getRangeElemSpan :: RangeTemplateElem -> Maybe RealSrcSpan
+getRangeElemSpan (RangeElem sp) = Just sp
+getRangeElemSpan _ = Nothing
+
+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  
+  setRange _ = id
+
+instance HasRange (OptionalInfo RngTemplateStage) where 
+  getRange = RealSrcSpan . (^. rngTemplateOptRange)
+  setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp  
+  setRange _ = id
+
+instance Show (SpanInfo RngTemplateStage) where
+  show rngNode = concatMap show $ rngNode ^. rngTemplateNodeElems
+instance Show (ListInfo RngTemplateStage) where
+  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 = "«.»"

@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase 
+           , FlexibleContexts
+           #-}
+-- | 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 SrcLoc
+import StringBuffer
+import Data.Map
+import Data.Monoid
+import Control.Reference
+import Control.Monad.State
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.Transform.RangeToRangeTemplate
+import Language.Haskell.Tools.Transform.RangeTemplate
+import Language.Haskell.Tools.Transform.SourceTemplate
+
+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
+
+-- 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 
+      (\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 ) 
+    (return ()) (return ())
+  where insertElem sp (i,m) = (i+1, insert (OrdSrcSpan 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' :: 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)
+        
+-- | 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)
+     (\(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))
+     (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft))) 
+     (return ()) (return ())
+  where getTextFor RangeChildElem = return ChildElem
+        getTextFor (RangeElem sp) = do (src:rest) <- get
+                                       put rest
+                                       return (TextElem src)

@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables
+           , LambdaCase
+           , FlexibleContexts
+           #-}
+-- | Transform a syntax tree with ranges to a syntax tree that has range templates. Cuts the ranges of children
+-- from the ranges of their parents and replaces it with placeholders.
+module Language.Haskell.Tools.Transform.RangeToRangeTemplate (cutUpRanges, fixRanges) where
+
+import Language.Haskell.Tools.AST
+
+import Data.Data
+import Data.List
+import Data.Maybe
+import Control.Reference hiding (element)
+import Control.Monad.State
+import SrcLoc
+import Language.Haskell.Tools.Transform.RangeTemplate
+
+import FastString as GHC
+
+import Debug.Trace
+
+-- | Creates a source template from the ranges and the input file.
+-- All source ranges must be good ranges.
+cutUpRanges :: forall node dom . SourceInfoTraversal node 
+                 => Ann node dom NormRangeStage
+                 -> Ann node dom RngTemplateStage
+cutUpRanges n = evalState (cutUpRanges' n) [[],[]]
+  where cutUpRanges' :: SourceInfoTraversal node => 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 :: (Show (x NormRangeStage), Show (x RngTemplateStage), HasRange (x NormRangeStage), HasRange (x RngTemplateStage)) 
+            => ([SrcSpan] -> x NormRangeStage -> x RngTemplateStage) -> x NormRangeStage -> State [[SrcSpan]] (x RngTemplateStage)
+        trf f ni = do (below : top : xs) <- get
+                      let res = f below ni
+                      put ([] : (top ++ [ getRange res ]) : xs)
+                      return res
+
+-- | Modifies ranges to contain their children
+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 RangeStage), 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 (RealSrcSpan $ collectSpanRanges (srcSpanStart resRange) top)
+                          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) = NormNodeInfo (foldl1 combineSrcSpans $ sp : cont)
+
+expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage
+expandListToContain cont (ListPos bef aft def ind sp) = NormListInfo bef aft def ind (RealSrcSpan $ collectSpanRanges sp cont)
+
+expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage
+expandOptToContain cont (OptionalPos bef aft sp) = NormOptInfo bef aft (RealSrcSpan $ collectSpanRanges sp cont)
+   
+-- | Cuts out a list of source ranges from a given range
+cutOutElemSpan :: [SrcSpan] -> SpanInfo NormRangeStage -> SpanInfo RngTemplateStage
+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 
+          = 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)) ++ "]")
+
+cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage
+cutOutElemList sps lp@(NormListInfo bef aft sep indented sp)
+  = let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
+     in RangeTemplateList wholeRange bef aft sep indented (getSeparators wholeRange sps)
+
+cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage
+cutOutElemOpt sps op@(NormOptInfo bef aft sp) 
+  = let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps
+     in RangeTemplateOpt wholeRange bef aft
+
+collectSpanRanges :: SrcLoc -> [SrcSpan] -> RealSrcSpan
+collectSpanRanges (RealSrcLoc loc) [] = realSrcLocSpan loc
+collectSpanRanges _ [] = error "collectSpanRanges: No real src loc for empty element"
+collectSpanRanges _ ls = case foldl1 combineSrcSpans ls of RealSrcSpan sp -> sp
+                     
+-- | Cuts out all elements from a list, the rest is the list of separators
+getSeparators :: RealSrcSpan -> [SrcSpan] -> [RealSrcSpan]
+getSeparators sp infos@(_:_:_)
+  = mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems)
+-- at least two elements needed or there can be no separators
+getSeparators sp _ = []
+                     
+-- | Breaks the given template element into possibly 2 or 3 parts by cutting out the given part
+-- 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) 
+              then [ RangeElem (mkRealSrcSpan (realSrcSpanStart outer) (realSrcSpanStart inner)) ]
+              else []) ++
+           [ RangeChildElem ] ++
+           (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) 
+              then [ RangeElem (mkRealSrcSpan (realSrcSpanEnd inner) (realSrcSpanEnd outer)) ]
+              else [])
+breakUpRangeElem outer inner = Nothing
+
+

@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances
+           , FlexibleContexts
+           , DeriveDataTypeable
+           , TemplateHaskell
+           , RecordWildCards
+           , TypeFamilies
+           #-}
+-- | 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
+
+import Data.Data
+import Data.String
+import Control.Reference
+import SrcLoc
+import Language.Haskell.Tools.AST
+
+instance SourceInfo SrcTemplateStage where
+  data SpanInfo SrcTemplateStage = SourceTemplateNode { _sourceTemplateNodeRange :: SrcSpan
+                                                      , _sourceTemplateNodeElems :: [SourceTemplateElem] 
+                                                      }
+    deriving (Eq, Ord, Data)
+  data ListInfo SrcTemplateStage = SourceTemplateList { _sourceTemplateListRange :: SrcSpan
+                                                      , _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
+                                                      }
+    deriving (Eq, Ord, Data)
+  data OptionalInfo SrcTemplateStage = SourceTemplateOpt { _sourceTemplateOptRange :: SrcSpan
+                                                         , _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
+                                                         }
+    deriving (Eq, Ord, Data)
+
+-- QUESTION: why cant these references be generated?
+
+sourceTemplateNodeRange :: Simple Lens (SpanInfo SrcTemplateStage) SrcSpan
+sourceTemplateNodeRange = lens _sourceTemplateNodeRange (\v s -> s { _sourceTemplateNodeRange = v })
+
+sourceTemplateNodeElems :: Simple Lens (SpanInfo SrcTemplateStage) [SourceTemplateElem]
+sourceTemplateNodeElems = lens _sourceTemplateNodeElems (\v s -> s { _sourceTemplateNodeElems = v })
+
+sourceTemplateListRange :: Simple Lens (ListInfo SrcTemplateStage) SrcSpan
+sourceTemplateListRange = lens _sourceTemplateListRange (\v s -> s { _sourceTemplateListRange = v })
+
+srcTmpListBefore :: Simple Lens (ListInfo SrcTemplateStage) String
+srcTmpListBefore = lens _srcTmpListBefore (\v s -> s { _srcTmpListBefore = v })
+
+srcTmpListAfter :: Simple Lens (ListInfo SrcTemplateStage) String
+srcTmpListAfter = lens _srcTmpListAfter (\v s -> s { _srcTmpListAfter = v })
+
+srcTmpDefaultSeparator :: Simple Lens (ListInfo SrcTemplateStage) String
+srcTmpDefaultSeparator = lens _srcTmpDefaultSeparator (\v s -> s { _srcTmpDefaultSeparator = v })
+
+srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) Bool
+srcTmpIndented = lens _srcTmpIndented (\v s -> s { _srcTmpIndented = v })
+
+srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [String]
+srcTmpSeparators = lens _srcTmpSeparators (\v s -> s { _srcTmpSeparators = v })
+
+sourceTemplateOptRange :: Simple Lens (OptionalInfo SrcTemplateStage) SrcSpan
+sourceTemplateOptRange = lens _sourceTemplateOptRange (\v s -> s { _sourceTemplateOptRange = v })
+
+srcTmpOptBefore :: Simple Lens (OptionalInfo SrcTemplateStage) String
+srcTmpOptBefore = lens _srcTmpOptBefore (\v s -> s { _srcTmpOptBefore = v })
+
+srcTmpOptAfter :: Simple Lens (OptionalInfo SrcTemplateStage) String
+srcTmpOptAfter = lens _srcTmpOptAfter (\v s -> s { _srcTmpOptAfter = v })
+      
+-- | An element of a source template for a singleton AST node.
+data SourceTemplateElem
+  = TextElem String -- ^ Source text belonging to the current node
+  | ChildElem -- ^ Placeholder for the next children of the node
+     deriving (Eq, Ord, Data)
+
+makeReferences ''SourceTemplateElem
+
+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 .=) 
+      
+instance Show (SpanInfo SrcTemplateStage) where
+  show (SourceTemplateNode rng sp) = concatMap show sp
+instance Show (ListInfo SrcTemplateStage) where
+  show SourceTemplateList{..} = "«*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ "*»"
+instance Show (OptionalInfo SrcTemplateStage) where
+  show SourceTemplateOpt{..} = "«?" ++ show _srcTmpOptBefore ++ " " ++ show _srcTmpOptAfter ++ "?»"
+
+instance Show SourceTemplateElem where
+  show (TextElem s) = s
+  show ChildElem = "«.»"
+

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings
+           , FlexibleContexts
+           , FlexibleInstances
+           #-}
+-- | Helper functions for working with source templates
+module Language.Haskell.Tools.Transform.SourceTemplateHelpers where
+
+import SrcLoc
+import Data.String
+import Data.List
+import Control.Reference
+import Data.Function (on)
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.Transform.SourceTemplate
+
+type ASTElement node dom = Ann node dom SrcTemplateStage
+type ASTOptional node dom = AnnMaybeG node dom SrcTemplateStage
+type ASTMulti node dom = AnnListG node dom SrcTemplateStage
+
+instance IsString (SpanInfo SrcTemplateStage) where
+  fromString s = SourceTemplateNode noSrcSpan [TextElem s]
+    
+child :: SpanInfo SrcTemplateStage
+child = SourceTemplateNode noSrcSpan [ChildElem]
+
+opt :: OptionalInfo SrcTemplateStage
+opt = SourceTemplateOpt noSrcSpan "" ""
+
+optBefore :: String -> OptionalInfo SrcTemplateStage
+optBefore s = SourceTemplateOpt noSrcSpan s ""
+
+optAfter :: String -> OptionalInfo SrcTemplateStage
+optAfter s = SourceTemplateOpt noSrcSpan "" s
+
+list :: ListInfo SrcTemplateStage
+list = SourceTemplateList noSrcSpan "" "" "" False []
+
+indentedList :: ListInfo SrcTemplateStage
+indentedList = SourceTemplateList noSrcSpan "" "" "\n" True []
+
+indentedListBefore :: String -> ListInfo SrcTemplateStage
+indentedListBefore bef = SourceTemplateList noSrcSpan bef "" "\n" True []
+
+indentedListAfter :: String -> ListInfo SrcTemplateStage
+indentedListAfter aft = SourceTemplateList noSrcSpan "" aft "\n" True []
+
+listSep :: String -> ListInfo SrcTemplateStage
+listSep s = SourceTemplateList noSrcSpan "" "" s False []
+
+listSepBefore :: String -> String -> ListInfo SrcTemplateStage
+listSepBefore s bef = SourceTemplateList noSrcSpan bef "" s False []
+
+listSepAfter :: String -> String -> ListInfo SrcTemplateStage
+listSepAfter s aft = SourceTemplateList noSrcSpan "" aft s False []
+
+listSepBeforeAfter :: String -> String -> String -> ListInfo SrcTemplateStage
+listSepBeforeAfter s bef aft = SourceTemplateList noSrcSpan bef aft s False []
+
+-- | Concatenates two source templates to produce a new template with all child elements.
+(<>) :: SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage
+SourceTemplateNode sp1 el1 <> SourceTemplateNode sp2 el2 = SourceTemplateNode (combineSrcSpans sp1 sp2) (el1 ++ el2)

@@ -1,7 +1,7 @@ name:                haskell-tools-prettyprint
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Pretty printing of Haskell-Tools AST
-description:         Converts the Haskell-Tools AST to text. 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.
+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
 license:             BSD3
 license-file:        LICENSE
@@ -13,13 +13,20 @@ 
 library
   exposed-modules:     Language.Haskell.Tools.PrettyPrint
-                     , Language.Haskell.Tools.PrettyPrint.RoseTree
-  build-depends:       base                  >=4.9   && <5.0
-                     , ghc                   >=8.0   && <8.1
-                     , mtl                   >=2.2   && <2.3
-                     , containers            >=0.5   && <0.6
-                     , references            >=0.3.2 && <1.0
-                     , haskell-tools-ast     >=0.2   && <0.3
-                     , haskell-tools-ast-trf >=0.2   && <0.3
-                     , split                 >=0.2   && <1.0
-  default-language:    Haskell2010+                     , Language.Haskell.Tools.Transform
+  other-modules:       Language.Haskell.Tools.PrettyPrint.RoseTree
+                     , Language.Haskell.Tools.Transform.RangeToRangeTemplate
+                     , Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate
+                     , Language.Haskell.Tools.Transform.RangeTemplate
+                     , Language.Haskell.Tools.Transform.SourceTemplate
+                     , Language.Haskell.Tools.Transform.SourceTemplateHelpers
+                     , Language.Haskell.Tools.Transform.PlaceComments
+  build-depends:       base              >= 4.9  && < 4.10
+                     , mtl               >= 2.2  && < 2.3
+                     , containers        >= 0.5  && < 0.6
+                     , references        >= 0.3  && < 0.4
+                     , uniplate          >= 1.6  && < 1.7
+                     , split             >= 0.2  && < 0.3
+                     , ghc               >= 8.0  && < 8.1
+                     , haskell-tools-ast >= 0.3  && < 0.4
+  default-language: Haskell2010