diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) 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.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 @@ 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 diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs --- a/src/Language/Fortran/Analysis/SemanticTypes.hs +++ b/src/Language/Fortran/Analysis/SemanticTypes.hs @@ -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 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) 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 @@ -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 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 @@ -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. diff --git a/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f b/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f new file mode 100644 --- /dev/null +++ b/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f @@ -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 diff --git a/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected b/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected new file mode 100644 --- /dev/null +++ b/test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected @@ -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 diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs --- a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs @@ -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 "" . B.pack +iParser incs = Parser.f77lInlineIncludes incs mempty "" . 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) 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 @@ -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