fortran-src 0.10.0 → 0.10.1

raw patch · 10 files changed

+232/−111 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• fortran-src.cabal +1/−1
• src/Language/Fortran/Parser.hs +12/−1
• src/Language/Fortran/Parser/Monad.hs +0/−11
• src/Language/Fortran/Rewriter.hs +24/−21
• src/Language/Fortran/Rewriter/Internal.hs +96/−59
• test-data/rewriter/replacementsmap-columnlimit/004_comment.f +1/−1
• test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected +1/−1
• test/Language/Fortran/Rewriter/InternalSpec.hs +86/−16
• test/Language/Fortran/RewriterSpec.hs +7/−0

@@ -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,

@@ -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 @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end. category:       Language

@@ -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  -------------------------------------------------------------------------------- 

@@ -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 

@@ -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' --

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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"