diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.10.1 (Aug 1, 2022) + * export `ParseErrorSimple` from `Parser`, not internal module `Parser.Monad` + * rewriter fixes #232 + ### 0.10.0 (Jul 13, 2022) * Fix parsing kind parameters like `a_1` on literals. Previously, that would be parsed as a kind parameter on a kind parameter. Now we don't do that, diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: fortran-src -version: 0.10.0 +version: 0.10.1 synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @@ project, which uses fortran-src as its front end. category: Language diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs --- a/src/Language/Fortran/Parser.hs +++ b/src/Language/Fortran/Parser.hs @@ -64,7 +64,7 @@ import qualified Data.Map as Map import Data.Map ( Map ) import Data.Generics.Uniplate.Operations ( descendBiM ) -import Control.Exception ( throwIO ) +import Control.Exception ( throwIO, Exception ) import System.FilePath ( () ) import System.Directory ( doesFileExist ) @@ -72,6 +72,17 @@ -- either a normalized error (tokens are printed) or an untransformed -- 'ProgramFile'. type Parser a = String -> B.ByteString -> Either ParseErrorSimple a + +-- Provides a way to aggregate errors that come +-- from parses with different token types +data ParseErrorSimple = ParseErrorSimple + { errorPos :: Position + , errorFilename :: String + , errorMsg :: String + } deriving (Exception) + +instance Show ParseErrorSimple where + show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err -------------------------------------------------------------------------------- diff --git a/src/Language/Fortran/Parser/Monad.hs b/src/Language/Fortran/Parser/Monad.hs --- a/src/Language/Fortran/Parser/Monad.hs +++ b/src/Language/Fortran/Parser/Monad.hs @@ -67,17 +67,6 @@ instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b) --- Provides a way to aggregate errors that come --- from parses with different token types -data ParseErrorSimple = ParseErrorSimple - { errorPos :: Position - , errorFilename :: String - , errorMsg :: String - } deriving (Exception) - -instance Show ParseErrorSimple where - show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err - class LastToken a b | a -> b where getLastToken :: (Show b) => a -> Maybe b diff --git a/src/Language/Fortran/Rewriter.hs b/src/Language/Fortran/Rewriter.hs --- a/src/Language/Fortran/Rewriter.hs +++ b/src/Language/Fortran/Rewriter.hs @@ -29,17 +29,18 @@ import qualified Data.ByteString.Lazy.Char8 as BC import qualified Language.Fortran.Rewriter.Internal as RI +import Control.Exception ( finally ) +import Control.Monad ( when ) +import Data.Bifunctor ( bimap ) import Data.List ( partition ) import qualified Data.Map as M import Language.Fortran.Util.Position ( lineCol , SrcSpan(..) ) -import System.Directory ( renameFile ) -import System.FilePath ( () - , takeFileName - , takeDirectory +import System.Directory ( doesFileExist + , removeFile + , renameFile ) -import System.IO.Temp ( withTempDirectory ) -- | Remove overlapping items from a list of replacements and return a pair of -- lists containing disjoint items and overlapping items, respectively. @@ -50,12 +51,12 @@ -- items. partitionOverlapping :: [RI.Replacement] -> ([RI.Replacement], [RI.Replacement]) partitionOverlapping [] = ([], []) -partitionOverlapping (r:rs) = - -- partition current list using front element, recurse on the disjoints - -- (r is always treated as disjoint, which gives the precedence) - let (disjoint, overlapping) = partition (RI.areDisjoint r) rs - (disjointRest, overlappingRest) = partitionOverlapping disjoint - in (r : disjointRest, overlapping <> overlappingRest) +partitionOverlapping repls = + let currentRepl = head repls + (overlapping, remaining) = + partition (not . RI.areDisjoint currentRepl) (tail repls) + nextResult = partitionOverlapping remaining + in Data.Bifunctor.bimap (currentRepl :) (overlapping <>) nextResult -- | Apply a list of 'Replacement's to the orginal source file. -- @@ -88,16 +89,18 @@ processReplacements rm = processReplacements_ $ M.toList rm processReplacements_ :: [(String, [RI.Replacement])] -> IO () -processReplacements_ = mapM_ go - where - go :: (String, [RI.Replacement]) -> IO () - go (filePath, repls) = do - contents <- BC.readFile filePath - let newContents = RI.applyReplacements contents repls - withTempDirectory (takeDirectory filePath) ('.' : takeFileName filePath) $ \tmpDir -> - let tmpFile = tmpDir "tmp.f" - in do BC.writeFile tmpFile newContents - renameFile tmpFile filePath +processReplacements_ [] = return () +processReplacements_ ((filePath, repls) : xs) = do + contents <- BC.readFile filePath + let newContents = RI.applyReplacements contents repls + tempFilePath = filePath ++ ".temp" + maybeRm = do + exists <- doesFileExist tempFilePath + when exists $ removeFile tempFilePath + flip finally maybeRm $ do + BC.writeFile tempFilePath newContents + renameFile tempFilePath filePath + processReplacements_ xs -- | Utility function to convert 'SrcSpan' to 'SourceRange' -- diff --git a/src/Language/Fortran/Rewriter/Internal.hs b/src/Language/Fortran/Rewriter/Internal.hs --- a/src/Language/Fortran/Rewriter/Internal.hs +++ b/src/Language/Fortran/Rewriter/Internal.hs @@ -14,6 +14,7 @@ module Language.Fortran.Rewriter.Internal where import Data.Int +import Data.Bifunctor ( first ) import Data.ByteString.Lazy.Char8 ( ByteString ) import qualified Data.ByteString.Lazy.Char8 as BC import Control.Exception ( Exception @@ -169,7 +170,9 @@ nextChunk :: [RChar] -> (Chunk, [RChar]) nextChunk [] = ([], []) -- if the current chunk is the start of inline comment, prepend it to next -nextChunk (rchar@(RChar (Just '!') True _ _) : xs) = (rchar : fst rec, snd rec) +nextChunk (rchar@(RChar (Just '!') True _ _) : xs) = Data.Bifunctor.first + (rchar :) + rec where rec = nextChunk xs nextChunk (rchar@(RChar _ True _ _) : xs) = ([rchar], xs) nextChunk rchars = nextChunk_ rchars @@ -178,7 +181,8 @@ nextChunk_ [] = ([], []) nextChunk_ ls@(RChar _ True _ _ : _) = ([], ls) nextChunk_ (rchar@(RChar (Just '\n') _ _ _) : xs) = ([rchar], xs) -nextChunk_ (rchar : xs) = (rchar : fst rec, snd rec) where rec = nextChunk_ xs +nextChunk_ (rchar : xs) = Data.Bifunctor.first (rchar :) rec + where rec = nextChunk_ xs -- | Splits ['RChar'] into 'Chunk's. allChunks :: [RChar] -> [Chunk] @@ -191,68 +195,101 @@ evaluateChunks :: [Chunk] -> ByteString evaluateChunks ls = evaluateChunks_ ls 0 Nothing +-- | This expands the chunks from the left to right. If the length +-- of what has already been put into the current line exceeds the +-- limit of 72 characters (excluding inline comments starting with +-- '!' and implicit comments starting at column 73) then it ends +-- the current line with a continuation, otherwise it simply adds +-- the line as-is. It also calculates if the chunk is inside or outside +-- of a string literal, using that to determine where explicit comments are +-- if any. +-- +-- In either case, we make sure that we are padding implicit +-- comments *from the original source* even if the tail of that +-- line has been moved onto a continuation line. evaluateChunks_ :: [Chunk] -> Int64 -> Maybe Char -> ByteString -evaluateChunks_ [] _ _ = "" -evaluateChunks_ (x : xs) currLen quotation = if overLength - then - "\n +" - <> evaluateRChars xPadded - <> maybe (evaluateChunks_ xs (6 + nextLen) nextState) - (\len -> evaluateChunks_ xs len nextState) - lastLen - else - chStr - <> maybe (evaluateChunks_ xs (currLen + nextLen) nextState) - (\len -> evaluateChunks_ xs len nextState) - lastLen +evaluateChunks_ [] _ _ = "" +evaluateChunks_ (x : xs) currLen quotation = + let chStr = evaluateRChars x + isQuote = (`elem` ['\'', '"']) + elemIndexOutsideStringLiteral currentState needle haystack = impl + currentState + needle + haystack + 0 + where + -- Search space is empty, therefore no result is possible + impl state _ "" _ = (state, Nothing) + -- We have already entered a string literal + impl state@(Just quoteChar) query (top : rest) idx + | top == quoteChar = impl Nothing query rest (idx + 1) + | otherwise = impl state query rest (idx + 1) + -- Searching outside a string literal, might find the query or + -- enter a string literal + impl Nothing query (top : rest) idx + | top == query = (Nothing, Just idx) + | isQuote top = impl (Just top) query rest (idx + 1) + | otherwise = impl Nothing query rest (idx + 1) + + -- length to the last line + lastLen = BC.elemIndex '\n' $ BC.reverse chStr + (nextState, explicitCommentIdx) = + elemIndexOutsideStringLiteral quotation '!' (BC.unpack chStr) + -- length of rest of the line ignoring explicit comments + nextLen = fromMaybe + (BC.length chStr) + -- \n cannot occur inside of string literals so it is okay to search + -- directly for it. '!' on the other hand is allowed inside strings + -- so it needs to be searched for outside string literals + (myMin (BC.elemIndex '\n' chStr) explicitCommentIdx) + overLength = currLen + nextLen > 72 && currLen > 0 + in if overLength + -- start a new line + then + let targetCol = 72 - 6 + in "\n +" + <> evaluateRChars (padImplicitComments x targetCol) + <> maybe (evaluateChunks_ xs (6 + nextLen) nextState) + (\len -> evaluateChunks_ xs len nextState) + lastLen + -- continue with the current line + else + let targetCol = 72 - fromIntegral currLen + in evaluateRChars (padImplicitComments x targetCol) + <> maybe (evaluateChunks_ xs (currLen + nextLen) nextState) + (\len -> evaluateChunks_ xs len nextState) + lastLen where - overLength = currLen + nextLen > 72 && currLen > 0 - xPadded = padImplicitComments x (72 - 6) - chStr = evaluateRChars x - isQuote = (`elem` ['\'', '"']) - nextLen = fromMaybe (BC.length chStr) - (myMin (BC.elemIndex '\n' chStr) explicitCommentIdx) -- don't line break for comments - lastLen = BC.elemIndex '\n' $ BC.reverse chStr -- min for maybes that doesn't short circuit if there's a Nothing - myMin y z = case (y, z) of - (Just a , Just b ) -> Just $ min a b - (Nothing, Just a ) -> Just a - (Just a , Nothing) -> Just a - (Nothing, Nothing) -> Nothing - (nextState, explicitCommentIdx) = - elemIndexOutsideStringLiteral quotation '!' (BC.unpack chStr) - elemIndexOutsideStringLiteral currentState needle haystack = elemIndexImpl_ - currentState - needle - haystack - 0 - where - -- Search space is empty, therefore no result is possible - elemIndexImpl_ state _ "" _ = (state, Nothing) - -- We have already entered a string literal - elemIndexImpl_ state@(Just quoteChar) query (top : rest) idx - | top == quoteChar = elemIndexImpl_ Nothing query rest (idx + 1) - | otherwise = elemIndexImpl_ state query rest (idx + 1) - -- Searching outside a string literal, might find the query or - -- enter a string literal - elemIndexImpl_ Nothing query (top : rest) idx - | top == query = (Nothing, Just idx) - | isQuote top = elemIndexImpl_ (Just top) query rest (idx + 1) - | otherwise = elemIndexImpl_ Nothing query rest (idx + 1) - - -- Text after line 72 is an implicit comment, so should stay there + myMin Nothing m = m + myMin m Nothing = m + myMin (Just a) (Just b) = Just $ min a b + -- Text after line 72 is an implicit comment, so should stay there regardless + -- of what happens to the rest of the source padImplicitComments :: Chunk -> Int -> Chunk - padImplicitComments chunk targetCol = case findCommentRChar chunk of - Just (index, rc) -> - take index chunk - ++ padCommentRChar rc (targetCol - index + 1) - : drop (index + 1) chunk - Nothing -> chunk + padImplicitComments chunk targetCol = + let zippedChunk = zip [0 ..] chunk + in case findCommentRChar zippedChunk of + Just (index, rc) -> + case + findExclamationRChar zippedChunk + >>= \(id2, _) -> return (id2 >= index) + of + Just False -> chunk -- in this case there's a "!" before column 73 + _ -> + take index chunk + ++ padCommentRChar rc (targetCol - index) + : drop (index + 1) chunk + Nothing -> chunk where - findCommentRChar :: Chunk -> Maybe (Int, RChar) - findCommentRChar = - find ((\(RChar _ _ (SourceLocation _ cl) _) -> cl == 72) . snd) - . zip [1 ..] + -- Find the first location of a '!' in the chunks + findExclamationRChar = find ((\(RChar c _ _ _) -> c == Just '!') . snd) + -- Find the location at column 73 in the original source. + -- If that character is a newline, ignore it + findCommentRChar = find + ( (\(RChar ch _ (SourceLocation _ cl) _) -> cl == 72 && ch /= Just '\n') + . snd + ) padCommentRChar :: RChar -> Int -> RChar padCommentRChar (RChar char _ loc repl) padding = RChar char diff --git a/test-data/rewriter/replacementsmap-columnlimit/004_comment.f b/test-data/rewriter/replacementsmap-columnlimit/004_comment.f --- a/test-data/rewriter/replacementsmap-columnlimit/004_comment.f +++ b/test-data/rewriter/replacementsmap-columnlimit/004_comment.f @@ -6,6 +6,6 @@ some_string = "some_string" if (foo) then - IF (some_string(0).eq.'s') foo=9 Text after col 72 are comments and should remain + IF (some_string(0).eq.'s') foo=9 Text after col 72 are comments and should remain endif end diff --git a/test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected b/test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected --- a/test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected +++ b/test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected @@ -7,6 +7,6 @@ if (foo) then IF (xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - +(0).eq.'s') foo=9 Text after col 72 are comments and should remain + +(0).eq.'s') foo=9 Text after col 72 are comments and should remain endif end diff --git a/test/Language/Fortran/Rewriter/InternalSpec.hs b/test/Language/Fortran/Rewriter/InternalSpec.hs --- a/test/Language/Fortran/Rewriter/InternalSpec.hs +++ b/test/Language/Fortran/Rewriter/InternalSpec.hs @@ -240,7 +240,7 @@ , RChar Nothing False (SourceLocation 0 6) "" ] chunk = nextChunk line - chunk `shouldBe` (take 2 line, drop 2 line) + chunk `shouldBe` splitAt 2 line it "Take next chunk (replacement in the begining)" $ do let line = [ RChar (Just 'D') True (SourceLocation 0 0) "repl" @@ -249,7 +249,7 @@ , RChar Nothing False (SourceLocation 0 3) "" ] chunk = nextChunk line - chunk `shouldBe` (take 1 line, drop 1 line) + chunk `shouldBe` splitAt 1 line it "Take next chunk (deletion in the begining)" $ do let line = [ RChar (Just 'D') True (SourceLocation 0 0) "" @@ -258,11 +258,11 @@ , RChar Nothing False (SourceLocation 0 3) "" ] chunk = nextChunk line - chunk `shouldBe` (take 1 line, drop 1 line) + chunk `shouldBe` splitAt 1 line it "Take next chunk (with a new line)" $ do let multiline = toRCharList "some text with\na new line" chunk = nextChunk multiline - chunk `shouldBe` (take 15 multiline, drop 15 multiline) + chunk `shouldBe` splitAt 15 multiline it "Take all chunks (single chunk)" $ do let line = toRCharList "A single chunk" chunks = allChunks line @@ -518,6 +518,88 @@ <> "\n +" <> BC.replicate 28 'a' ) + it "Apply replacement (continuation line with comments)" $ do + let source = + BC.replicate 6 ' ' + <> "abcdefg" -- 7 characters + <> BC.replicate 59 ' ' + <> BC.replicate 4 'c' -- starts exactly at 73 + range = SourceRange (SourceLocation 0 6) (SourceLocation 0 6) + replS = "1234" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` ( BC.replicate 6 ' ' + <> BC.pack replS -- 4 characters + <> "a\n +bcdefg" -- 6 characters + <> BC.replicate 60 ' ' + <> BC.replicate 4 'c' -- starts exactly at 73 + ) + it "Apply replacement (continuation line with comments in continuation)" + $ do + let prefix = BC.replicate 6 ' ' <> "abcdefg + 56\n +" + source = + prefix + <> "abcdefg" -- 7 characters after continuation + <> BC.replicate 59 ' ' + <> "+ 56" -- starts exactly at 73 + range = SourceRange (SourceLocation 1 6) (SourceLocation 1 6) + replS = "1234" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` ( prefix + <> BC.pack replS -- 4 characters + <> "a\n +bcdefg" -- 6 characters + <> BC.replicate 60 ' ' + <> "+ 56" -- starts exactly at 73 + ) + it "Apply replacement (forced continuation line with comments)" $ do + let + source + = " write(8, *) '>>>>>>>>>>>>>>>>>>>> ', 5 + 3422 + p6uUiD + 4" + -- ^ column 64 + range = SourceRange (SourceLocation 0 64) (SourceLocation 0 70) + replS = "sespit_get_p6uuid()" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` (" write(8, *) '>>>>>>>>>>>>>>>>>>>> ', 5 + 3422 + \n" + <> " +sespit_get_p6uuid() + 4" + ) + it "Apply replacement inside string (inline comment over column 72)" $ do + let + source + = " write(8, *) 'hi' ! this comment goes way over the limit................" + -- ^ column 72 + range = SourceRange (SourceLocation 0 19) (SourceLocation 0 21) + replS = "hello" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` " write(8, *) 'hello' ! this comment goes way over the limit................" + it "Apply replacement outside string (inline comment over column 72)" $ do + let + source + = " write(8, *) 'hi', varHi ! this comment goes way over the limit................" + -- ^ column 72 + range = SourceRange (SourceLocation 0 27) (SourceLocation 0 29) + replS = "Hello" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` " write(8, *) 'hi', varHello ! this comment goes way over the limit................" + it "Apply replacement ('!' in a string literal)" $ do + let + source = + " write(8, *) 'hi! this string is really long, overflowing even'" + -- ^ column 68 + range = SourceRange (SourceLocation 0 68) (SourceLocation 0 68) + replS = ", variableHello" + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` " write(8, *) 'hi! this string is really long, overflowing even'\n +, variableHello" it "Apply replacement (insertion in the middle)" $ do let source = "abc" range = SourceRange (SourceLocation 0 0) (SourceLocation 0 0) @@ -546,18 +628,6 @@ <> BC.pack replS1 <> BC.pack replS2 <> BC.replicate 24 'a' - it "Apply replacement ('!' in a string literal)" $ do - let - source = - " write(8, *) 'hi! this string is really long, overflowing even'" - -- ^ Column 68 - range = SourceRange (SourceLocation 0 68) (SourceLocation 0 68) - replS = ", variableHello" - r = Replacement range replS - res = applyReplacements source [r] - res - `shouldBe` - " write(8, *) 'hi! this string is really long, overflowing even'\n +, variableHello" it "Apply replacements (overlapping)" $ do let source = BC.replicate 30 'a' range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) diff --git a/test/Language/Fortran/RewriterSpec.hs b/test/Language/Fortran/RewriterSpec.hs --- a/test/Language/Fortran/RewriterSpec.hs +++ b/test/Language/Fortran/RewriterSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Language.Fortran.RewriterSpec ( spec @@ -221,18 +222,22 @@ "999999999999999999999" ] ) +#ifndef mingw32_HOST_OS + -- TODO fails on Windows due to some line ending/spacing bug , ( workDir ++ "002_other.f" , [ Replacement (SourceRange (SourceLocation 4 61) (SourceLocation 4 62)) "999999999999" ] ) + -- TODO fails on Windows due to some line ending/spacing bug , ( workDir ++ "003_multiline.f" , [ Replacement (SourceRange (SourceLocation 4 61) (SourceLocation 4 62)) "9 .and. \n + 4 .lt. 4\n + .or. .true." ] ) +#endif , ( workDir ++ "004_comment.f" , [ Replacement (SourceRange (SourceLocation 2 18) (SourceLocation 2 19)) @@ -288,8 +293,10 @@ Nothing "replacementsmap-columnlimit" [ "001_foo.f" +#ifndef mingw32_HOST_OS , "002_other.f" , "003_multiline.f" +#endif , "004_comment.f" , "005_removals.f" , "006_linewrap_heuristic.f"