diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/Tools/AnnTrf/PlaceComments.hs b/Language/Haskell/Tools/AnnTrf/PlaceComments.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/PlaceComments.hs @@ -0,0 +1,152 @@ +{-# 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.AnnTrf.PlaceComments where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe +import Data.List +import Data.String.Utils +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 Data.StructuralTraversal + +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) = startswith "{-#" str && endswith "#-}" 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 :: (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 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 :: StructuralTraversable node => Ann node (NodeInfo sema SpanInfo) -> [SrcSpan] +allElemSpans = execWriter . traverseDown (return ()) (return ()) + (\ni -> maybe (return ()) (tell . (:[])) (ni ^? sourceInfo&nodeSpan)) + +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 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) + $ elem + +type ExpandType elem sema = Ann elem (NodeInfo sema SpanInfo) + -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] + (Ann elem (NodeInfo sema SpanInfo)) + +-- | Expands tree elements to contain the comments that should be attached to them. +expandAnnot :: forall elem sema . ExpandType elem sema +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 (NodeInfo sema SpanInfo)) 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)) + +expandAnnotToFunArgs :: ExpandType TypeSignature sema +expandAnnotToFunArgs = element&tsType&typeParams !~ expandAnnot diff --git a/Language/Haskell/Tools/AnnTrf/RangeTemplate.hs b/Language/Haskell/Tools/AnnTrf/RangeTemplate.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/RangeTemplate.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell + , DeriveDataTypeable + #-} +-- | 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.AnnTrf.RangeTemplate where + +import Data.Data +import Control.Reference +import SrcLoc + +data RangeTemplateElem = RangeElem RealSrcSpan + | RangeChildElem + | RangeOptionalElem String String + | RangeListElem String String String Bool [RealSrcSpan] + deriving Data + +getRangeElemSpan :: RangeTemplateElem -> Maybe RealSrcSpan +getRangeElemSpan (RangeElem sp) = Just sp +getRangeElemSpan _ = Nothing + +instance Show RangeTemplateElem where + show (RangeElem sp) = show 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 diff --git a/Language/Haskell/Tools/AnnTrf/RangeTemplateToSourceTemplate.hs b/Language/Haskell/Tools/AnnTrf/RangeTemplateToSourceTemplate.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/RangeTemplateToSourceTemplate.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase + , FlexibleContexts + #-} +module Language.Haskell.Tools.AnnTrf.RangeTemplateToSourceTemplate where + +import SrcLoc +import StringBuffer +import Data.StructuralTraversal +import Data.Map +import Data.Monoid +import Control.Reference +import Control.Monad.State +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate +import Language.Haskell.Tools.AnnTrf.RangeTemplate +import Language.Haskell.Tools.AnnTrf.SourceTemplate + +import Debug.Trace + +rangeToSource :: StructuralTraversable node => StringBuffer -> Ann node (NodeInfo sema RangeTemplate) + -> Ann node (NodeInfo sema SourceTemplate) +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 :: StructuralTraversable e => Ann e (NodeInfo sema RangeTemplate) -> 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)) + 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 :: StructuralTraversable node => [String] -> Ann node (NodeInfo sema RangeTemplate) + -> Ann node (NodeInfo sema SourceTemplate) +applyFragments srcs = flip evalState srcs + . traverseDown + (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 + 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) + diff --git a/Language/Haskell/Tools/AnnTrf/RangeToRangeTemplate.hs b/Language/Haskell/Tools/AnnTrf/RangeToRangeTemplate.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/RangeToRangeTemplate.hs @@ -0,0 +1,111 @@ +{-# 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.AnnTrf.RangeToRangeTemplate (cutUpRanges, fixRanges) where + +import Language.Haskell.Tools.AST + +import Data.Data +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 + +-- | 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 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 + + -- 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) + +-- | 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) [[],[]] + 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)) + +-- | 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 + +-- | Expand any node to contain its children +expandAsNodeToContain :: SpanInfo -> [SpanInfo] -> SpanInfo +expandAsNodeToContain ns@(NodeSpan _) ls = expandToContain ls ns +expandAsNodeToContain oth ls = expandAsNodeInfo oth ls + +-- | 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) + 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) + +collectSpanRanges :: SrcLoc -> [SpanInfo] -> 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 + +-- | Cuts out all elements from a list, the rest is the list of separators +getSeparators :: RealSrcSpan -> [SpanInfo] -> [RealSrcSpan] +getSeparators sp infos@(_:_:_) + = mapMaybe getRangeElemSpan (cutOutElem infos (NodeSpan (RealSrcSpan sp)) ^. rangeTemplateElems) +-- 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 + + diff --git a/Language/Haskell/Tools/AnnTrf/SourceTemplate.hs b/Language/Haskell/Tools/AnnTrf/SourceTemplate.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/SourceTemplate.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances + , FlexibleContexts + , DeriveDataTypeable + , TemplateHaskell + , RecordWildCards + #-} +-- | 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.AnnTrf.SourceTemplate where + +import Data.Data +import Data.String +import Control.Reference +import SrcLoc +import Language.Haskell.Tools.AST + +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 ''SourceTemplate + +instance HasRange (NodeInfo sema SourceTemplate) where + getRange = (^. sourceInfo&sourceTemplateRange) + +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 diff --git a/Language/Haskell/Tools/AnnTrf/SourceTemplateHelpers.hs b/Language/Haskell/Tools/AnnTrf/SourceTemplateHelpers.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/AnnTrf/SourceTemplateHelpers.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings + , FlexibleContexts + #-} +-- | Helper functions for working with source templates +module Language.Haskell.Tools.AnnTrf.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.AnnTrf.SourceTemplate + +filterList :: TemplateAnnot a => (Ann e a -> Bool) -> AnnList e a -> AnnList e a +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 + where mostCommonSeparator + = case getTemplate a ^. sourceTemplateElems of + [ChildListElem _ _ sep _ seps] -> case maximumBy (compare `on` length) $ group $ sort seps of + [] -> sep + sep:_ -> sep + +-- | 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 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) + $ 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 + 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 before after [] + | before Nothing && after Nothing = Just 0 + | otherwise = Nothing +insertIndex before after list@(first:_) + | before Nothing && after (Just first) = Just 0 + | otherwise = (+1) <$> insertIndex' before after list + where insertIndex' before after (curr:rest@(next:_)) + | before (Just curr) && after (Just next) = Just 0 + | otherwise = (+1) <$> insertIndex' before after rest + 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] + +child :: SourceTemplate +child = SourceTemplate noSrcSpan [ChildElem] + +opt :: SourceTemplate +opt = SourceTemplate noSrcSpan [OptionalChildElem "" ""] + +optBefore :: String -> SourceTemplate +optBefore s = SourceTemplate noSrcSpan [OptionalChildElem s ""] + +optAfter :: String -> SourceTemplate +optAfter s = SourceTemplate noSrcSpan [OptionalChildElem "" s] + +list :: SourceTemplate +list = SourceTemplate noSrcSpan [ChildListElem "" "" "" False []] + +indentedList :: SourceTemplate +indentedList = SourceTemplate noSrcSpan [ChildListElem "" "" "\n" True []] + +indentedListBefore :: String -> SourceTemplate +indentedListBefore bef = SourceTemplate noSrcSpan [ChildListElem bef "" "\n" True []] + +indentedListAfter :: String -> SourceTemplate +indentedListAfter aft = SourceTemplate noSrcSpan [ChildListElem "" aft "\n" True []] + +listSep :: String -> SourceTemplate +listSep s = SourceTemplate noSrcSpan [ChildListElem "" "" s False []] + +listSepBefore :: String -> String -> SourceTemplate +listSepBefore s bef = SourceTemplate noSrcSpan [ChildListElem bef "" s False []] + +listSepAfter :: String -> String -> SourceTemplate +listSepAfter s aft = SourceTemplate noSrcSpan [ChildListElem "" 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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-tools-ast-trf.cabal b/haskell-tools-ast-trf.cabal new file mode 100644 --- /dev/null +++ b/haskell-tools-ast-trf.cabal @@ -0,0 +1,30 @@ +name: haskell-tools-ast-trf +version: 0.1.2.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 +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate + , Language.Haskell.Tools.AnnTrf.RangeTemplateToSourceTemplate + , Language.Haskell.Tools.AnnTrf.RangeTemplate + , Language.Haskell.Tools.AnnTrf.SourceTemplate + , Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers + , Language.Haskell.Tools.AnnTrf.PlaceComments + build-depends: base >=4.9 && <5.0 + , ghc >=8.0 && <8.1 + , haskell-tools-ast >=0.1 && <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 + default-language: Haskell2010