haskell-tools-ast-trf 0.1.2.0 → 0.1.3.0
raw patch · 7 files changed
+311/−191 lines, 7 filesdep −structural-traversaldep ~haskell-tools-ast
Dependencies removed: structural-traversal
Dependency ranges changed: haskell-tools-ast
Files
- Language/Haskell/Tools/AnnTrf/PlaceComments.hs +52/−28
- Language/Haskell/Tools/AnnTrf/RangeTemplate.hs +75/−17
- Language/Haskell/Tools/AnnTrf/RangeTemplateToSourceTemplate.hs +21/−23
- Language/Haskell/Tools/AnnTrf/RangeToRangeTemplate.hs +51/−45
- Language/Haskell/Tools/AnnTrf/SourceTemplate.hs +69/−26
- Language/Haskell/Tools/AnnTrf/SourceTemplateHelpers.hs +41/−49
- haskell-tools-ast-trf.cabal +2/−3
Language/Haskell/Tools/AnnTrf/PlaceComments.hs view
@@ -17,7 +17,6 @@ import Control.Reference hiding (element) import Control.Monad.Writer import Control.Monad.State -import Data.StructuralTraversal import SrcLoc import ApiAnnotation @@ -40,10 +39,9 @@ -- | 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 :: (StructuralTraversable node, Data sema, Data (node (NodeInfo sema SpanInfo)), Typeable node) - => Map.Map SrcSpan [Located AnnotationComment] - -> Ann node (NodeInfo sema SpanInfo) - -> Ann node (NodeInfo sema SpanInfo) +placeComments :: RangeInfo stage => Map.Map SrcSpan [Located AnnotationComment] + -> Ann Module dom stage + -> Ann Module dom stage placeComments comms mod = resizeAnnots (concatMap (map nextSrcLoc . snd) (Map.toList comms)) mod where spans = allElemSpans mod @@ -54,35 +52,64 @@ before = fromMaybe noSrcLoc (Set.lookupGE (srcSpanEnd sp) sortedElemStarts) in ((after,before),comm) -allElemSpans :: StructuralTraversable node => Ann node (NodeInfo sema SpanInfo) -> [SrcSpan] -allElemSpans = execWriter . traverseDown (return ()) (return ()) - (\ni -> maybe (return ()) (tell . (:[])) (ni ^? sourceInfo&nodeSpan)) +allElemSpans :: (SourceInfoTraversal node, RangeInfo stage) => Ann node dom stage -> [SrcSpan] +allElemSpans = execWriter . sourceInfoTraverse (SourceInfoTrf (\ni -> tell [ni ^. nodeSpan] >> pure ni) pure pure) -resizeAnnots :: forall node sema . (Data sema, Data (node (NodeInfo sema SpanInfo)), Typeable node) - => [((SrcLoc, SrcLoc), Located AnnotationComment)] - -> Ann node (NodeInfo sema SpanInfo) - -> Ann node (NodeInfo sema SpanInfo) +resizeAnnots :: RangeInfo stage => [((SrcLoc, SrcLoc), Located AnnotationComment)] + -> Ann Module dom stage + -> Ann Module 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 - transformBiM (expandAnnot :: ExpandType ImportDecl sema) - >=> transformBiM (expandAnnotToFunArgs :: ExpandType TypeSignature sema) - >=> transformBiM (expandAnnot :: ExpandType Decl sema) - >=> transformBiM (expandAnnot :: ExpandType ClassElement sema) - >=> transformBiM (expandAnnot :: ExpandType ConDecl sema) - >=> transformBiM (expandAnnot :: ExpandType FieldDecl sema) - >=> transformBiM (expandAnnot :: ExpandType LocalBind sema) - >=> transformBiM (expandAnnot :: ExpandType Module sema) + element&modImports&annList !~ expandAnnot -- expand imports to cover their comments + >=> element&modDecl&annList !~ expandTopLevelDecl -- expand declarations to cover their comments + >=> expandAnnot -- expand the module itself to cover its comments $ elem -type ExpandType elem sema = Ann elem (NodeInfo sema SpanInfo) - -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] - (Ann elem (NodeInfo sema SpanInfo)) +type ExpandType elem dom stage = Ann elem dom stage -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] (Ann elem dom stage) +expandTopLevelDecl :: RangeInfo stage => ExpandType Decl dom stage +expandTopLevelDecl + = element & declBody & annJust & element & cbElements & annList !~ expandClsElement + >=> element & declCons & annList !~ expandConDecl + >=> element & declGadt & annList !~ expandGadtConDecl + >=> element & declTypeSig !~ expandTypeSig + >=> expandAnnot + +expandTypeSig :: RangeInfo stage => ExpandType TypeSignature dom stage +expandTypeSig + = element & tsType & typeParams !~ expandAnnot >=> expandAnnot + +expandClsElement :: RangeInfo stage => ExpandType ClassElement dom stage +expandClsElement + = element & ceTypeSig !~ expandTypeSig + >=> element & ceBind !~ expandValueBind + >=> expandAnnot + +expandValueBind :: RangeInfo stage => ExpandType ValueBind dom stage +expandValueBind + = element & valBindLocals & annJust & element & localBinds & annList !~ expandLocalBind + >=> element & funBindMatches & annList & element & matchBinds & annJust & element & localBinds & annList !~ expandLocalBind + >=> expandAnnot + +expandLocalBind :: RangeInfo stage => ExpandType LocalBind dom stage +expandLocalBind + = element & localVal !~ expandValueBind + >=> element & localSig !~ expandTypeSig + >=> expandAnnot + +expandConDecl :: RangeInfo stage => ExpandType ConDecl dom stage +expandConDecl + = element & conDeclFields & annList !~ expandAnnot >=> expandAnnot + +expandGadtConDecl :: RangeInfo stage => ExpandType GadtConDecl dom stage +expandGadtConDecl + = element & gadtConType & element & gadtConRecordFields & annList !~ expandAnnot >=> expandAnnot + -- | Expands tree elements to contain the comments that should be attached to them. -expandAnnot :: forall elem sema . ExpandType elem sema +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)) @@ -96,7 +123,7 @@ 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 (NodeInfo sema SpanInfo)) SrcSpan + 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 @@ -147,6 +174,3 @@ -- the comment string contains the -- or {- characters firstNonspaceCharIs :: Char -> String -> Bool firstNonspaceCharIs c s = Just c == listToMaybe (dropWhile isSpace (drop 2 s)) - -expandAnnotToFunArgs :: ExpandType TypeSignature sema -expandAnnotToFunArgs = element&tsType&typeParams !~ expandAnnot
Language/Haskell/Tools/AnnTrf/RangeTemplate.hs view
@@ -1,5 +1,8 @@ {-# 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. @@ -8,29 +11,84 @@ import Data.Data import Control.Reference import SrcLoc +import Language.Haskell.Tools.AST -data RangeTemplateElem = RangeElem RealSrcSpan - | RangeChildElem - | RangeOptionalElem String String - | RangeListElem String String String Bool [RealSrcSpan] +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) +instance HasRange (ListInfo RngTemplateStage) where + getRange = RealSrcSpan . (^. rngTemplateListRange) +instance HasRange (OptionalInfo RngTemplateStage) where + getRange = RealSrcSpan . (^. rngTemplateOptRange) + +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) = show sp + show (RangeElem sp) = shortShowSpan (RealSrcSpan sp) show RangeChildElem = "«.»" - show (RangeOptionalElem bef aft) = "«?" ++ show bef ++ " " ++ show aft ++ "?»" - show (RangeListElem bef aft sep _ _) = "«*" ++ show bef ++ " " ++ show sep ++ " " ++ show aft ++ "*»" - --- | The intermediate annotation with ranges and children cut out from parents. -data RangeTemplate = RangeTemplate { _rangeTemplateSpan :: RealSrcSpan - , _rangeTemplateElems :: [RangeTemplateElem] - } deriving Data - -makeReferences ''RangeTemplate - -instance Show RangeTemplate where - show (RangeTemplate rng rngs) = show rngs
Language/Haskell/Tools/AnnTrf/RangeTemplateToSourceTemplate.hs view
@@ -5,7 +5,6 @@ import SrcLoc import StringBuffer -import Data.StructuralTraversal import Data.Map import Data.Monoid import Control.Reference @@ -17,8 +16,8 @@ import Debug.Trace -rangeToSource :: StructuralTraversable node => StringBuffer -> Ann node (NodeInfo sema RangeTemplate) - -> Ann node (NodeInfo sema SourceTemplate) +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 @@ -26,13 +25,13 @@ -- maps could be strict -- | Assigns an index (in the order they are used) for each range -getLocIndices :: StructuralTraversable e => Ann e (NodeInfo sema RangeTemplate) -> Map OrdSrcSpan Int +getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Map OrdSrcSpan Int getLocIndices = snd . flip execState (0, empty) . - traverseDown (return ()) (return ()) - (mapM_ (\case RangeElem sp -> modify (insertElem sp) - RangeListElem _ _ _ _ seps -> mapM_ (modify . insertElem) seps - _ -> return () - ) . (^. sourceInfo&rangeTemplateElems)) + 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) @@ -49,20 +48,19 @@ takeSpan' _ _ (rem, taken) = (rem, taken) -- | Replaces the ranges in the AST with the source file parts -applyFragments :: StructuralTraversable node => [String] -> Ann node (NodeInfo sema RangeTemplate) - -> Ann node (NodeInfo sema SourceTemplate) +applyFragments :: SourceInfoTraversal node => [String] -> Ann node dom RngTemplateStage + -> Ann node dom SrcTemplateStage applyFragments srcs = flip evalState srcs - . traverseDown + . 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 ()) - (\ni -> do template <- mapM getTextFor (ni ^. sourceInfo&rangeTemplateElems) - return $ sourceInfo .= SourceTemplate (RealSrcSpan $ ni ^. sourceInfo&rangeTemplateSpan) template $ ni) - where getTextFor (RangeElem sp) = do (src:rest) <- get + where getTextFor RangeChildElem = return ChildElem + getTextFor (RangeElem sp) = do (src:rest) <- get put rest - return (TextElem src) - getTextFor RangeChildElem = return ChildElem - getTextFor (RangeOptionalElem bef aft) = return (OptionalChildElem bef aft) - getTextFor (RangeListElem bef aft sep indented seps) - = do (own, rest) <- splitAt (length seps) <$> get - put rest - return (ChildListElem bef aft sep indented own) - + return (TextElem src)
Language/Haskell/Tools/AnnTrf/RangeToRangeTemplate.hs view
@@ -12,85 +12,91 @@ import Data.List import Data.Maybe import Control.Reference hiding (element) -import Data.StructuralTraversal import Control.Monad.State import SrcLoc import Language.Haskell.Tools.AnnTrf.RangeTemplate +import Debug.Trace + -- | Creates a source template from the ranges and the input file. -- All source ranges must be good ranges. -cutUpRanges :: forall node sema . StructuralTraversable node - => Ann node (NodeInfo sema SpanInfo) - -> Ann node (NodeInfo sema RangeTemplate) +cutUpRanges :: forall node dom . SourceInfoTraversal node + => Ann node dom NormRangeStage + -> Ann node dom RngTemplateStage cutUpRanges n = evalState (cutUpRanges' n) [[],[]] - where cutUpRanges' :: StructuralTraversable node => Ann node (NodeInfo sema SpanInfo) - -> State [[SpanInfo]] (Ann node (NodeInfo sema RangeTemplate)) - cutUpRanges' = traverseUp desc asc f + 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 - f ni = do (below : top : xs) <- get - put ([] : (top ++ [ expandAsNodeInfo (ni ^. sourceInfo) below ]) : xs) - return (sourceInfo .- cutOutElem below $ ni) + 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 :: StructuralTraversable node - => Ann node (NodeInfo sema SpanInfo) - -> Ann node (NodeInfo sema SpanInfo) -fixRanges node = evalState (traverseUp desc asc f node) [[],[]] +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 - f ni = do (below : top : xs) <- get - put ([] : (top ++ [ expandAsNodeToContain (ni ^. sourceInfo) below ]) : xs) - return (sourceInfo .- expandToContain below $ ni) - --- | Expand a list or optional node to contain its children -expandAsNodeInfo :: SpanInfo -> [SpanInfo] -> SpanInfo -expandAsNodeInfo ns@(NodeSpan _) _ = ns -expandAsNodeInfo OptionalPos{_optionalPos = loc} sps = NodeSpan (RealSrcSpan (collectSpanRanges loc sps)) -expandAsNodeInfo ListPos{_listPos = loc} sps = NodeSpan (RealSrcSpan (collectSpanRanges loc sps)) + 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 + put ([] : (top ++ [ getRange res ]) : xs) + return res -- | Expand a simple node to contain its children -expandToContain :: [SpanInfo] -> SpanInfo -> SpanInfo -expandToContain cont (NodeSpan sp) = NodeSpan (foldl1 combineSrcSpans $ sp : map spanRange cont) -expandToContain _ oth = oth +expandToContain :: [SrcSpan] -> SpanInfo RangeStage -> SpanInfo NormRangeStage +expandToContain cont (NodeSpan sp) = NormNodeInfo (foldl1 combineSrcSpans $ sp : cont) --- | Expand any node to contain its children -expandAsNodeToContain :: SpanInfo -> [SpanInfo] -> SpanInfo -expandAsNodeToContain ns@(NodeSpan _) ls = expandToContain ls ns -expandAsNodeToContain oth ls = expandAsNodeInfo oth ls - +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 -cutOutElem :: [SpanInfo] -> SpanInfo -> RangeTemplate -cutOutElem sps lp@(ListPos bef aft sep indented loc) - = let wholeRange = collectSpanRanges loc sps - in RangeTemplate wholeRange [RangeListElem bef aft sep indented (getSeparators wholeRange sps)] -cutOutElem sps op@(OptionalPos bef aft loc) - = RangeTemplate (collectSpanRanges loc sps) [RangeOptionalElem bef aft] -cutOutElem sps (NodeSpan (RealSrcSpan sp)) - = RangeTemplate sp $ foldl breakFirstHit (foldl breakFirstHit [RangeElem sp] loc) span - where (loc,span) = partition (\sp -> srcSpanStart sp == srcSpanEnd sp) (map spanRange sps) +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: didn't find correct place for " ++ show sp) + breakFirstHit [] sp = error ("breakFirstHit: didn't find correct place for " ++ show sp ++ " in " ++ show sp ++ " with " ++ show sps) -collectSpanRanges :: SrcLoc -> [SpanInfo] -> RealSrcSpan +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 $ map spanRange ls of RealSrcSpan sp -> sp +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 -> [SpanInfo] -> [RealSrcSpan] +getSeparators :: RealSrcSpan -> [SrcSpan] -> [RealSrcSpan] getSeparators sp infos@(_:_:_) - = mapMaybe getRangeElemSpan (cutOutElem infos (NodeSpan (RealSrcSpan sp)) ^. rangeTemplateElems) + = mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems) -- at least two elements needed or there can be no separators getSeparators sp _ = []
Language/Haskell/Tools/AnnTrf/SourceTemplate.hs view
@@ -3,6 +3,7 @@ , 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. @@ -14,39 +15,81 @@ import SrcLoc import Language.Haskell.Tools.AST -data SourceTemplateElem +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) + +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 - | OptionalChildElem { _srcTmpBefore :: String -- ^ Text that should be put before the element if it appears - , _srcTmpAfter :: String -- ^ Text that should be put after the element if it appears - } - | ChildListElem { _srcTmpBefore :: String -- ^ Text that should be put before the first element if the list becomes populated - , _srcTmpAfter :: 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) - -makeReferences ''SourceTemplateElem --- | A pattern that controls how the original source code can be --- retrieved from the AST. A source template is assigned to each node. --- It has holes where the content of an other node should be printed. -data SourceTemplate = SourceTemplate { _sourceTemplateRange :: SrcSpan - , _sourceTemplateElems :: [SourceTemplateElem] - } deriving Data +makeReferences ''SourceTemplateElem -makeReferences ''SourceTemplate - -instance HasRange (NodeInfo sema SourceTemplate) where - getRange = (^. sourceInfo&sourceTemplateRange) +instance HasRange (SpanInfo SrcTemplateStage) where + getRange = (^. sourceTemplateNodeRange) +instance HasRange (ListInfo SrcTemplateStage) where + getRange = (^. sourceTemplateListRange) +instance HasRange (OptionalInfo SrcTemplateStage) where + getRange = (^. 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 = "«.»" - show OptionalChildElem{..} = "«?" ++ show _srcTmpBefore ++ " " ++ show _srcTmpAfter ++ "?»" - show ChildListElem{..} = "«*" ++ show _srcTmpBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpAfter ++ "*»" -instance Show SourceTemplate where - show (SourceTemplate rng sp) = concatMap show sp
Language/Haskell/Tools/AnnTrf/SourceTemplateHelpers.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings , FlexibleContexts + , FlexibleInstances #-} -- | Helper functions for working with source templates module Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers where @@ -12,39 +13,36 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AnnTrf.SourceTemplate -filterList :: TemplateAnnot a => (Ann e a -> Bool) -> AnnList e a -> AnnList e a +filterList :: (Ann e dom SrcTemplateStage -> Bool) -> AnnList e dom SrcTemplateStage -> AnnList e dom SrcTemplateStage filterList pred ls = replaceList (filter pred (ls ^. annListElems)) ls -- | Replaces the list with a new one with the given elements, keeping the most common separator as the new one. -replaceList :: TemplateAnnot a => [Ann e a] -> AnnList e a -> AnnList e a -replaceList elems (AnnList a _) - = AnnList (fromTemplate (listSep mostCommonSeparator)) elems +replaceList :: [Ann e dom SrcTemplateStage] -> AnnList e dom SrcTemplateStage -> AnnList e dom SrcTemplateStage +replaceList elems (AnnList (NodeInfo sema src) _) + = AnnList (NodeInfo sema (listSep mostCommonSeparator)) elems where mostCommonSeparator - = case getTemplate a ^. sourceTemplateElems of - [ChildListElem _ _ sep _ seps] -> case maximumBy (compare `on` length) $ group $ sort seps of - [] -> sep - sep:_ -> sep + = case group $ sort (src ^. srcTmpSeparators) of + [] -> src ^. srcTmpDefaultSeparator + nonempty@(_:_) -> head $ maximumBy (compare `on` length) nonempty -- | Inserts the element in the places where the two positioning functions (one checks the element before, one the element after) -- allows the placement. -insertWhere :: (TemplateAnnot a) => Ann e a -> (Maybe (Ann e a) -> Bool) -> (Maybe (Ann e a) -> Bool) -> AnnList e a -> AnnList e a +insertWhere :: Ann e dom SrcTemplateStage -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) + -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> AnnList e dom SrcTemplateStage + -> AnnList e dom SrcTemplateStage insertWhere e before after al = let index = insertIndex before after (al ^? annList) in case index of Nothing -> al Just ind -> annListElems .- insertAt ind e - $ (if isEmptyAnnList then id else addDefaultSeparator ind) + $ (if isEmptyAnnList then id else annListAnnot&sourceInfo .- addDefaultSeparator ind) $ al - where addDefaultSeparator i al - = srcTemplateElems&srcTmpSeparators - .- insertAt i (head $ al ^? srcTemplateElems&srcTmpDefaultSeparator) $ al - srcTemplateElems :: (TemplateAnnot a) => Simple Traversal (AnnList e a) SourceTemplateElem - srcTemplateElems = annListAnnot&template&sourceTemplateElems&traversal + where addDefaultSeparator i al = srcTmpSeparators .- insertAt i (al ^. srcTmpDefaultSeparator) $ al insertAt n e ls = let (bef,aft) = splitAt n ls in bef ++ [e] ++ aft isEmptyAnnList = (null :: [x] -> Bool) $ (al ^? annList) -- | Checks where the element will be inserted given the two positioning functions. -insertIndex :: (Maybe (Ann e a) -> Bool) -> (Maybe (Ann e a) -> Bool) -> [Ann e a] -> Maybe Int +insertIndex :: (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> (Maybe (Ann e dom SrcTemplateStage) -> Bool) -> [Ann e dom SrcTemplateStage] -> Maybe Int insertIndex before after [] | before Nothing && after Nothing = Just 0 | otherwise = Nothing @@ -57,49 +55,43 @@ insertIndex' before after (curr:[]) | before (Just curr) && after Nothing = Just 0 | otherwise = Nothing - -class TemplateAnnot annot where - template :: Simple Lens annot SourceTemplate - template = iso getTemplate fromTemplate - fromTemplate :: SourceTemplate -> annot - getTemplate :: annot -> SourceTemplate - -instance IsString SourceTemplate where - fromString s = SourceTemplate noSrcSpan [TextElem s] + +instance IsString (SpanInfo SrcTemplateStage) where + fromString s = SourceTemplateNode noSrcSpan [TextElem s] -child :: SourceTemplate -child = SourceTemplate noSrcSpan [ChildElem] +child :: SpanInfo SrcTemplateStage +child = SourceTemplateNode noSrcSpan [ChildElem] -opt :: SourceTemplate -opt = SourceTemplate noSrcSpan [OptionalChildElem "" ""] +opt :: OptionalInfo SrcTemplateStage +opt = SourceTemplateOpt noSrcSpan "" "" -optBefore :: String -> SourceTemplate -optBefore s = SourceTemplate noSrcSpan [OptionalChildElem s ""] +optBefore :: String -> OptionalInfo SrcTemplateStage +optBefore s = SourceTemplateOpt noSrcSpan s "" -optAfter :: String -> SourceTemplate -optAfter s = SourceTemplate noSrcSpan [OptionalChildElem "" s] +optAfter :: String -> OptionalInfo SrcTemplateStage +optAfter s = SourceTemplateOpt noSrcSpan "" s -list :: SourceTemplate -list = SourceTemplate noSrcSpan [ChildListElem "" "" "" False []] +list :: ListInfo SrcTemplateStage +list = SourceTemplateList noSrcSpan "" "" "" False [] -indentedList :: SourceTemplate -indentedList = SourceTemplate noSrcSpan [ChildListElem "" "" "\n" True []] +indentedList :: ListInfo SrcTemplateStage +indentedList = SourceTemplateList noSrcSpan "" "" "\n" True [] -indentedListBefore :: String -> SourceTemplate -indentedListBefore bef = SourceTemplate noSrcSpan [ChildListElem bef "" "\n" True []] +indentedListBefore :: String -> ListInfo SrcTemplateStage +indentedListBefore bef = SourceTemplateList noSrcSpan bef "" "\n" True [] -indentedListAfter :: String -> SourceTemplate -indentedListAfter aft = SourceTemplate noSrcSpan [ChildListElem "" aft "\n" True []] +indentedListAfter :: String -> ListInfo SrcTemplateStage +indentedListAfter aft = SourceTemplateList noSrcSpan "" aft "\n" True [] -listSep :: String -> SourceTemplate -listSep s = SourceTemplate noSrcSpan [ChildListElem "" "" s False []] +listSep :: String -> ListInfo SrcTemplateStage +listSep s = SourceTemplateList noSrcSpan "" "" s False [] -listSepBefore :: String -> String -> SourceTemplate -listSepBefore s bef = SourceTemplate noSrcSpan [ChildListElem bef "" s False []] +listSepBefore :: String -> String -> ListInfo SrcTemplateStage +listSepBefore s bef = SourceTemplateList noSrcSpan bef "" s False [] -listSepAfter :: String -> String -> SourceTemplate -listSepAfter s aft = SourceTemplate noSrcSpan [ChildListElem "" aft s False []] +listSepAfter :: String -> String -> ListInfo SrcTemplateStage +listSepAfter s aft = SourceTemplateList noSrcSpan "" aft s False [] -- | Concatenates two source templates to produce a new template with all child elements. -(<>) :: SourceTemplate -> SourceTemplate -> SourceTemplate -SourceTemplate sp1 el1 <> SourceTemplate sp2 el2 = SourceTemplate (combineSrcSpans sp1 sp2) (el1 ++ el2) +(<>) :: SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage +SourceTemplateNode sp1 el1 <> SourceTemplateNode sp2 el2 = SourceTemplateNode (combineSrcSpans sp1 sp2) (el1 ++ el2)
haskell-tools-ast-trf.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-ast-trf -version: 0.1.2.0 +version: 0.1.3.0 synopsis: Conversions on Haskell-Tools AST to prepare for refactorings description: Converts the Haskell-Tools AST between different versions to have source annotations that help refactorings. Have transformations that convert from ranges to range templates and then to source templates. Also have a transformation to put comments to their places. homepage: https://github.com/nboldi/haskell-tools @@ -20,10 +20,9 @@ , Language.Haskell.Tools.AnnTrf.PlaceComments build-depends: base >=4.9 && <5.0 , ghc >=8.0 && <8.1 - , haskell-tools-ast >=0.1 && <1.0 + , haskell-tools-ast >=0.1.3 && <1.0 , uniplate >=1.6 && <2.0 , references >=0.3.2 && <1.0 - , structural-traversal >=0.1 && <1.0 , mtl >=2.2 && <2.3 , containers >=0.5 && <0.6 , MissingH >=1.3 && <2.0