fortran-src 0.11.0 → 0.12.0

raw patch · 9 files changed

+152/−81 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• fortran-src.cabal +15/−13
• src/Language/Fortran/Analysis/SemanticTypes.hs +43/−14
• src/Language/Fortran/Parser.hs +34/−38
• src/Language/Fortran/Rewriter/Internal.hs +19/−14
• test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f +4/−0
• test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected +5/−0
• test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +2/−2
• test/Language/Fortran/RewriterSpec.hs +20/−0

@@ -1,3 +1,13 @@+### Unreleased (major ver.)+  * clean up F77 include inlining (#245, @RaoulHC)+    * directly export F77 include parser at `f77lIncludesNoTransform`+    * `f77lIncIncludes :: String -> ByteString -> IO [Block A0]` should now be+      defined by the user e.g. `\fn bs -> throwIOLeft $ f77lIncludesNoTransform+      fn bs`+  * `Language.Fortran.Analysis.SemanticTypes`: alter `SemType` constructor+    `TArray` to support assumed-size (e.g. `integer arr(*)`) arrays (#244)+  * `Language.Fortran.Rewriter`: fix inline comment padding (#242, @RaoulHC)+ ### 0.11.0 (Oct 10, 2022)   * add strong Fortran value & type representation at `Language.Fortran.Repr`     (currently unused) (#235, @raehik)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.11.0+version:        0.12.0 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@@ -45,6 +45,8 @@     test-data/rewriter/replacementsmap-overlapping-filtered/001_foo.f.expected     test-data/rewriter/replacementsmap-overlapping/001_foo.f     test-data/rewriter/replacementsmap-overlapping/001_foo.f.expected+    test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f+    test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected     test-data/rewriter/replacementsmap-simple/001_foo.f     test-data/rewriter/replacementsmap-simple/001_foo.f.expected     test-data/rewriter/replacementsmap-simple/002_foo.f@@ -193,11 +195,11 @@     , filepath ==1.4.*     , mtl >=2.2 && <3     , pretty >=1.1 && <2-    , singletons >=3.0-    , singletons-base >=3.0-    , singletons-th >=3.0+    , singletons >=3.0 && <3.2+    , singletons-base >=3.0 && <3.2+    , singletons-th >=3.0 && <3.2     , temporary >=1.2 && <1.4-    , text >=1.2 && <2+    , text >=1.2 && <2.1     , uniplate >=1.6 && <2     , vector-sized >=1.5.0 && <1.6   default-language: Haskell2010@@ -257,11 +259,11 @@     , fortran-src     , mtl >=2.2 && <3     , pretty >=1.1 && <2-    , singletons >=3.0-    , singletons-base >=3.0-    , singletons-th >=3.0+    , singletons >=3.0 && <3.2+    , singletons-base >=3.0 && <3.2+    , singletons-th >=3.0 && <3.2     , temporary >=1.2 && <1.4-    , text >=1.2 && <2+    , text >=1.2 && <2.1     , uniplate >=1.6 && <2     , vector-sized >=1.5.0 && <1.6   default-language: Haskell2010@@ -353,11 +355,11 @@     , hspec >=2.2 && <3     , mtl >=2.2 && <3     , pretty >=1.1 && <2-    , singletons >=3.0-    , singletons-base >=3.0-    , singletons-th >=3.0+    , singletons >=3.0 && <3.2+    , singletons-base >=3.0 && <3.2+    , singletons-th >=3.0 && <3.2     , temporary >=1.2 && <1.4-    , text >=1.2 && <2+    , text >=1.2 && <2.1     , uniplate >=1.6 && <2     , vector-sized >=1.5.0 && <1.6   default-language: Haskell2010

@@ -2,7 +2,7 @@  module Language.Fortran.Analysis.SemanticTypes where -import           Data.Data                      ( Data, Typeable )+import           Data.Data                      ( Data ) import           Control.DeepSeq                ( NFData ) import           GHC.Generics                   ( Generic ) import           Language.Fortran.AST           ( BaseType(..)@@ -33,13 +33,18 @@   | TLogical Kind   | TByte Kind   | TCharacter CharacterLen Kind-  | TArray SemType (Maybe Dimensions) -- ^ Nothing denotes dynamic dimensions-  | TCustom String                    -- use for F77 structures, F90 DDTs-  deriving (Eq, Ord, Show, Data, Typeable, Generic) -instance Binary SemType-instance Out    SemType+  | TArray SemType Dimensions+  -- ^ A Fortran array type is defined by a single type, and a set of+  --   dimensions. Note that assumed-shape arrays which only "store" array rank+  --   cannot be represented. +  | TCustom String+  -- ^ Constructor to use for F77 structures, F90 DDTs++    deriving stock    (Ord, Eq, Show, Data, Generic)+    deriving anyclass (NFData, Binary, Out)+ -- TODO placeholder, not final or tested -- should really attempt to print with kind info, and change to DOUBLE PRECISION -- etc. for <F90. Maybe cheat, use 'recoverSemTypeTypeSpec' and print resulting@@ -55,10 +60,37 @@     TArray st _ -> pprint' v st <+> parens "(A)"     TCustom str -> pprint' v (TypeCustom str) --- | The declared dimensions of a staticically typed array variable--- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]-type Dimensions = [(Int, Int)]+-- | The declared dimensions of an array variable.+--+-- Each dimension is of the form @(dim_lower, dim_upper)@.+data Dimensions+  = DimensionsCons !(Int, Int) Dimensions+  -- ^ Another dimension in the dimension list. +  | DimensionsEnd+  -- ^ No more dimensions.++  | DimensionsFinalStar+  -- ^ The final dimension is dynamic (represented by a star @*@ in syntax).+  --   This indicates an assumed-size array.+    deriving stock    (Ord, Eq, Show, Data, Generic)+    deriving anyclass (NFData, Binary, Out)++-- | Convert 'Dimensions' data type to its previous type synonym+--   @(Maybe [(Int, Int)])@.+--+-- Will not return @Just []@.+dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)]+dimensionsToTuples = \case+  DimensionsCons bounds ds -> Just $ reverse $ go [bounds] ds+  DimensionsEnd       -> Nothing+  DimensionsFinalStar -> Nothing+  where+    go boundss = \case+      DimensionsCons bounds ds -> go (bounds:boundss) ds+      DimensionsEnd       -> boundss+      DimensionsFinalStar -> boundss+ --------------------------------------------------------------------------------  data CharacterLen = CharLenStar    -- ^ specified with a *@@ -66,11 +98,8 @@                     -- FIXME, possibly, with a more robust const-exp:                   | CharLenExp     -- ^ specified with a non-trivial expression                   | CharLenInt Int -- ^ specified with a constant integer-  deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary CharacterLen-instance Out    CharacterLen-instance NFData CharacterLen+    deriving stock    (Ord, Eq, Show, Data, Generic)+    deriving anyclass (NFData, Binary, Out)  charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String) charLenSelector Nothing                          = (Nothing, Nothing)

@@ -22,6 +22,7 @@    -- * Other parsers   , f90Expr+  , f77lIncludesNoTransform   , byVerFromFilename    -- ** Statement@@ -38,11 +39,11 @@   , initParseStateFixedExpr, initParseStateFreeExpr   , parseUnsafe   , collectTokensSafe, collectTokens+  , throwIOLeft    -- * F77 with inlined includes   -- $f77includes-  , f77lIncludes-  , f77lIncIncludes+  , f77lInlineIncludes   ) where  import Language.Fortran.AST@@ -85,11 +86,16 @@   { errorPos      :: Position   , errorFilename :: String   , errorMsg      :: String-  } deriving (Exception)+  } deriving anyclass (Exception)  instance Show ParseErrorSimple where   show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err +-- | May be used to lift parse results into IO and force unwrap.+throwIOLeft :: (Exception e, MonadIO m) => Either e a -> m a+throwIOLeft = \case Right a -> pure a+                    Left  e -> liftIO $ throwIO e+ --------------------------------------------------------------------------------  byVer :: FortranVersion -> Parser (ProgramFile A0)@@ -285,55 +291,45 @@ Can be cleaned up and generalized to use for other parsers. -} -f77lIncludes+f77lInlineIncludes     :: [FilePath] -> ModFiles -> String -> B.ByteString     -> IO (ProgramFile A0)-f77lIncludes incs mods fn bs = do+f77lInlineIncludes incs mods fn bs = do     case f77lNoTransform fn bs of       Left e -> liftIO $ throwIO e       Right pf -> do         let pf' = pfSetFilename fn pf-        pf'' <- evalStateT (descendBiM (f77lIncludesInline incs []) pf') Map.empty+        pf'' <- evalStateT (descendBiM (f77lInlineIncludes' incs []) pf') Map.empty         let pf''' = runTransform (combinedTypeEnv mods)                                  (combinedModuleMap mods)                                  (defaultTransformation Fortran77Legacy)                                  pf''         return pf''' --- | Entry point for include files--- --- We can't perform full analysis (though it might be possible to do in future)--- but the AST is enough for certain types of analysis/refactoring-f77lIncIncludes-  :: [FilePath] -> String -> B.ByteString -> IO [Block A0]-f77lIncIncludes incs fn bs =-  case makeParserFixed F77.includesParser Fortran77Legacy fn bs of-    Left e -> liftIO $ throwIO e-    Right bls ->-      evalStateT (descendBiM (f77lIncludesInline incs []) bls) Map.empty--f77lIncludesInner :: Parser [Block A0]-f77lIncludesInner = makeParserFixed F77.includesParser Fortran77Legacy--f77lIncludesInline+f77lInlineIncludes'     :: [FilePath] -> [FilePath] -> Statement A0     -> StateT (Map String [Block A0]) IO (Statement A0)-f77lIncludesInline dirs seen st = case st of-  StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do-    if notElem path seen then do-      incMap <- get-      case Map.lookup path incMap of-        Just blocks' -> pure $ StInclude a s e (Just blocks')-        Nothing -> do-          (fullPath, inc) <- liftIO $ readInDirs dirs path-          case f77lIncludesInner fullPath inc of-            Right blocks -> do-              blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks-              modify (Map.insert path blocks')-              return $ StInclude a s e (Just blocks')-            Left err -> liftIO $ throwIO err-    else return st-  _ -> return st+f77lInlineIncludes' dirs = go+  where+    go seen st = case st of+      StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do+        if notElem path seen then do+          incMap <- get+          case Map.lookup path incMap of+            Just blocks' -> pure $ StInclude a s e (Just blocks')+            Nothing -> do+              (fullPath, incBs) <- liftIO $ readInDirs dirs path+              case f77lIncludesNoTransform fullPath incBs of+                Right blocks -> do+                  blocks' <- descendBiM (go (path:seen)) blocks+                  modify (Map.insert path blocks')+                  pure $ StInclude a s e (Just blocks')+                Left err -> liftIO $ throwIO err+        else pure st+      _ -> pure st++f77lIncludesNoTransform :: Parser [Block A0]+f77lIncludesNoTransform = makeParserFixed F77.includesParser Fortran77Legacy  readInDirs :: [String] -> String -> IO (String, B.ByteString) readInDirs [] f = fail $ "cannot find file: " ++ f

@@ -267,20 +267,22 @@   -- 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 =-    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+  padImplicitComments chunk targetCol+    | isMarkedForRemoval chunk = chunk+    | otherwise =+      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     -- Find the first location of a '!' in the chunks     findExclamationRChar = find ((\(RChar c _ _ _) -> c == Just '!') . snd)@@ -298,6 +300,9 @@       (BC.pack (replicate padding ' ' ++ maybeToList char) `BC.append` repl)  +isMarkedForRemoval (RChar _ True _ _ : _) = True+isMarkedForRemoval (_ : rs) = isMarkedForRemoval rs+isMarkedForRemoval [] = False  -- | Return TRUE iff the 'Replacement' constitutes a character -- insertion.

@@ -0,0 +1,4 @@+      program main+      integer hello*4 ! This is a long comment that goes over the 72 columns+     +      , hello2*2+      end program main

@@ -0,0 +1,5 @@+      program main+      ! This is a long comment that goes over the 72 columns+      integer*4 hello+      integer*2 hello2+      end program main

@@ -6,13 +6,13 @@ import Test.Hspec import TestUtil -import Language.Fortran.Parser ( f77lIncludes )+import qualified Language.Fortran.Parser as Parser import Language.Fortran.AST import Language.Fortran.Util.Position import qualified Data.ByteString.Char8 as B  iParser :: [String] -> String -> IO (ProgramFile A0)-iParser incs = f77lIncludes incs mempty "<unknown>" . B.pack+iParser incs = Parser.f77lInlineIncludes incs mempty "<unknown>" . B.pack  makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing)

@@ -300,6 +300,26 @@         , "006_linewrap_heuristic.f"         ] #endif+    it "implicit comment removal" $ do+      base <- getCurrentDirectory+      let+        body workDir = processReplacements $ M.fromList+          [ ( workDir ++ "001_foo.f"+            , [ Replacement+                  (SourceRange (SourceLocation 1 0) (SourceLocation 3 0))+                  $ unlines [ "      ! This is a long comment that goes over the 72 columns"+                            , "      integer*4 hello"+                            , "      integer*2 hello2"+                            ]+              ]+            )+          ]+      wrapReplacementsMapInvocationTestHelper+        body+        base+        Nothing+        "replacementsmap-padimplicitcomment"+        [ "001_foo.f" ]    describe "Filtering overlapping replacements" $ do     it "Simple overlap" $ do