diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +### 0.4.2 (March 03, 2021) + + * `FortranVersion` from `ParserMonad` moved to its own module + `Language.Fortran.Version`. `ParserMonad` will re-export it for now. + * `Version.deduceVersion` renamed to `deduceFortranVersion` due to often being + imported non-qualified. `deduceVersion` remains as an alias. + * Provide a continuation reformatter in `PrettyPrint`. Runs on `String`s and + doesn't guarantee the output is a valid program, so not enabled by default. + * Add a diff-like rewriter, similar to + [reprinter](http://hackage.haskell.org/package/reprinter) but uses + replacements rather than an annotated AST. + * Various internal de-duplication and changes. + +### 0.4.1 + +* Ignore comments in structure declaration PR#107 (thanks Jason Xu) + ### 0.4.0 (August 29, 2019) * ModGraph: parse Fortran files and assemble them into a dependency graph in order to construct automated 'build' plans for analysis and summarisation (e.g. with --make-mods option). diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# fortran-src + +![CI status badge](https://github.com/camfort/fortran-src/workflows/CI/badge.svg) + +Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95 and part of Fortran 2003. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project (https://github.com/camfort/camfort), which uses fortran-src as its front end. + +For features that output graphs, the intended usage is to pipe it into the command 'dot -Tpdf' and redirect that into a PDF file. The 'dot' command is part of the GraphViz project (https://www.graphviz.org/), please see their manual for the many other options that can be explored for visualisation purposes. + + Usage: fortran-src [OPTION...] + -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90] + -a ACTION --action=ACTION lex or parse action + -t --typecheck parse and run typechecker + -R --rename parse and rename variables + -B --bblocks analyse basic blocks + -S --supergraph analyse super graph of basic blocks + -r --reprint Parse and output using pretty printer + --dot output graphs in GraphViz DOT format + --dump-mod-file dump the information contained within mod files + -I DIR --include-dir=DIR directory to search for precompiled 'mod files' + -c --compile compile an .fsmod file from the input + --show-block-numbers[=LINE-NUM] Show the corresponding AST-block identifier number next to every line of code. + --show-flows-to=AST-BLOCK-ID dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph + --show-flows-from=AST-BLOCK-ID dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph + +## Installation + +### Build from source + +Stack 2.x is required for building. *(Stack 1.x may work with minor alternations -- you may have to download the resolver manually.)* + +Clone the repository and install [Stack](https://docs.haskellstack.org/en/stable/README/). + +``` +stack setup +stack build +``` + +### Using Cabal + +Install [Cabal](https://www.haskell.org/cabal/). + +``` +cabal install fortran-src +``` diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -1,14 +1,14 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 7ecba9dfd6edf736093629bbf1b7aa27d0e4d21260c2e931eaabda5aa5ff2c82 +-- hash: 50aa4fb72aab53b1e5d449fa390ff3290fb26bd9bf9297a7cac174a79ef92b3f name: fortran-src -version: 0.4.0 -synopsis: Parser and anlyses for Fortran standards 66, 77, 90 and 95. +version: 0.4.2 +synopsis: Parsers and analyses for Fortran standards 66, 77, 90 and 95. description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end. category: Language homepage: https://github.com/camfort/fortran-src#readme @@ -19,6 +19,7 @@ license-file: LICENSE build-type: Simple extra-source-files: + README.md CHANGELOG.md source-repository head @@ -34,6 +35,7 @@ Language.Fortran.Analysis.BBlocks Language.Fortran.Analysis.DataFlow Language.Fortran.AST + Language.Fortran.Version Language.Fortran.LValue Language.Fortran.Intrinsics Language.Fortran.Lexer.FixedForm @@ -56,48 +58,53 @@ Language.Fortran.Util.FirstParameter Language.Fortran.Util.SecondParameter Language.Fortran.Util.ModFile + Language.Fortran.Util.Files + Language.Fortran.Rewriter + Language.Fortran.Rewriter.Internal hs-source-dirs: src - ghc-options: -fno-warn-tabs + ghc-options: -Wall -fno-warn-tabs + build-tools: + alex >=3.1 + , happy >=1.19 build-depends: GenericPretty >=1.2.2 && <2 , array >=0.5 && <0.6 , base >=4.6 && <5 - , binary >=0.8.3.0 && <0.9 - , bytestring >=0.10 && <0.11 + , binary >=0.8.3.0 && <0.11 + , bytestring >=0.10 && <0.12 , containers >=0.5 && <0.7 - , deepseq + , deepseq >=1.4 && <1.5 , directory >=1.2 && <2 , fgl >=5 && <6 - , filepath >=1.4 && <2 + , filepath >=1.4 && <1.5 , mtl >=2.2 && <3 , pretty >=1.1 && <2 + , temporary >=1.2 && <1.4 , text >=1.2 && <2 , uniplate >=1.6 && <2 - build-tools: - alex >=3.1 - , happy >=1.19 default-language: Haskell2010 executable fortran-src main-is: src/Main.hs other-modules: Paths_fortran_src - ghc-options: -fno-warn-tabs + ghc-options: -Wall -fno-warn-tabs build-depends: GenericPretty >=1.2.2 && <2 , array >=0.5 && <0.6 , base >=4.6 && <5 - , binary >=0.8.3.0 && <0.9 - , bytestring >=0.10 && <0.11 + , binary >=0.8.3.0 && <0.11 + , bytestring >=0.10 && <0.12 , containers >=0.5 && <0.7 - , deepseq + , deepseq >=1.4 && <1.5 , directory >=1.2 && <2 , fgl >=5 && <6 - , filepath >=1.4 && <2 + , filepath >=1.4 && <1.5 , fortran-src , mtl >=2.2 && <3 , pretty >=1.1 && <2 + , temporary >=1.2 && <1.4 , text >=1.2 && <2 , uniplate >=1.6 && <2 default-language: Haskell2010 @@ -123,6 +130,8 @@ Language.Fortran.Parser.UtilsSpec Language.Fortran.ParserMonadSpec Language.Fortran.PrettyPrintSpec + Language.Fortran.Rewriter.InternalSpec + Language.Fortran.RewriterSpec Language.Fortran.Transformation.Disambiguation.FunctionSpec Language.Fortran.Transformation.GroupingSpec Language.Fortran.Util.FirstParameterSpec @@ -131,21 +140,25 @@ Paths_fortran_src hs-source-dirs: test + ghc-options: -Wall + build-tool-depends: + hspec-discover:hspec-discover build-depends: GenericPretty >=1.2.2 && <2 , array >=0.5 && <0.6 , base >=4.6 && <5 - , binary >=0.8.3.0 && <0.9 - , bytestring >=0.10 && <0.11 + , binary >=0.8.3.0 && <0.11 + , bytestring >=0.10 && <0.12 , containers >=0.5 && <0.7 - , deepseq + , deepseq >=1.4 && <1.5 , directory >=1.2 && <2 , fgl >=5 && <6 - , filepath >=1.4 && <2 + , filepath >=1.4 && <1.5 , fortran-src , hspec >=2.2 && <3 , mtl >=2.2 && <3 , pretty >=1.1 && <2 + , temporary >=1.2 && <1.4 , text >=1.2 && <2 , uniplate >=1.6 && <2 default-language: Haskell2010 diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs --- a/src/Language/Fortran/AST.hs +++ b/src/Language/Fortran/AST.hs @@ -15,7 +15,6 @@ import Data.Generics.Uniplate.Data () import Data.Typeable () import Data.Binary -import GHC.Generics (Generic) import Control.DeepSeq import Text.PrettyPrint.GenericPretty import Language.Fortran.ParserMonad (FortranVersion(..)) diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs --- a/src/Language/Fortran/Analysis.hs +++ b/src/Language/Fortran/Analysis.hs @@ -22,7 +22,6 @@ import Language.Fortran.LValue import Data.Graph.Inductive (Node, empty) import Data.Graph.Inductive.PatriciaTree (Gr) -import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty import Text.PrettyPrint hiding (empty, isEmpty) import qualified Data.Map.Strict as M diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs --- a/src/Language/Fortran/Analysis/BBlocks.hs +++ b/src/Language/Fortran/Analysis/BBlocks.hs @@ -21,7 +21,6 @@ import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Graph.Inductive -import Data.Graph.Inductive.PatriciaTree (Gr) import Data.List (intercalate) import Data.Maybe import Data.Functor.Identity diff --git a/src/Language/Fortran/Analysis/DataFlow.hs b/src/Language/Fortran/Analysis/DataFlow.hs --- a/src/Language/Fortran/Analysis/DataFlow.hs +++ b/src/Language/Fortran/Analysis/DataFlow.hs @@ -40,7 +40,6 @@ import qualified Data.Set as S import qualified Data.IntSet as IS import Data.Graph.Inductive hiding (trc, dom, order, inn, out, rc) -import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Maybe import Data.List (foldl', foldl1', (\\), union, intersect) import Control.Monad.Writer hiding (fix) diff --git a/src/Language/Fortran/Analysis/ModGraph.hs b/src/Language/Fortran/Analysis/ModGraph.hs --- a/src/Language/Fortran/Analysis/ModGraph.hs +++ b/src/Language/Fortran/Analysis/ModGraph.hs @@ -11,19 +11,16 @@ import Data.Data import Data.Generics.Uniplate.Data import Data.Graph.Inductive hiding (version) -import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Maybe -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (replace) import Language.Fortran.AST hiding (setName) -import Language.Fortran.Parser.Any -import Language.Fortran.ParserMonad (FortranVersion(..), fromRight) +import Language.Fortran.Version (FortranVersion(..), deduceFortranVersion) +import Language.Fortran.Parser.Any (parserWithModFilesVersions) +import Language.Fortran.ParserMonad (fromRight) import Language.Fortran.Util.ModFile -import qualified Data.ByteString.Char8 as B +import Language.Fortran.Util.Files import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.Map as M import System.IO -import System.Directory import System.FilePath -------------------------------------------------- @@ -88,7 +85,7 @@ let iter :: FilePath -> ModGrapher () iter path = do contents <- liftIO $ flexReadFile path - let version = fromMaybe (deduceVersion path) mversion + let version = fromMaybe (deduceFortranVersion path) mversion let (Just parserF0) = lookup version parserWithModFilesVersions let parserF m b s = fromRight (parserF0 m b s) fileMods <- liftIO $ decodeModFiles includeDirs @@ -129,10 +126,7 @@ -------------------------------------------------- -flexReadFile :: String -> IO B.ByteString -flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile - -decodeModFiles :: [String] -> IO [(FilePath, ModFile)] +decodeModFiles :: [FilePath] -> IO [(FilePath, ModFile)] decodeModFiles = foldM (\ modFiles d -> do -- Figure out the camfort mod files and parse them. modFileNames <- filter isModFile `fmap` getDirContents d @@ -146,13 +140,7 @@ hPutStrLn stderr $ modFileName ++ ": successfully parsed precompiled file." return $ map (modFileName,) mods return $ addedModFiles ++ modFiles - ) [] + ) [] -- can't use emptyModFiles isModFile :: FilePath -> Bool isModFile = (== modFileSuffix) . takeExtension - --- List files in dir -getDirContents :: String -> IO [String] -getDirContents d = do - d' <- canonicalizePath d - map (d' ) `fmap` listDirectory d' diff --git a/src/Language/Fortran/Analysis/Renaming.hs b/src/Language/Fortran/Analysis/Renaming.hs --- a/src/Language/Fortran/Analysis/Renaming.hs +++ b/src/Language/Fortran/Analysis/Renaming.hs @@ -17,11 +17,10 @@ import Language.Fortran.ParserMonad (FortranVersion(..)) import Prelude hiding (lookup) -import Data.Maybe (mapMaybe, maybe, fromMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.List as L import Data.Map (insert, empty, lookup, Map) import qualified Data.Map.Strict as M -import Control.Monad (void) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data diff --git a/src/Language/Fortran/Lexer/FixedForm.x b/src/Language/Fortran/Lexer/FixedForm.x --- a/src/Language/Fortran/Lexer/FixedForm.x +++ b/src/Language/Fortran/Lexer/FixedForm.x @@ -15,7 +15,7 @@ import Data.Word (Word8) import Data.Char (toLower, ord, isDigit) -import Data.List (isPrefixOf, any) +import Data.List (isPrefixOf) import Data.Maybe (fromJust, isNothing, isJust) import Data.Data import qualified Data.Bits @@ -929,6 +929,9 @@ -- Ignore inline comments | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai + -- Ignore comments after column 72 in fortran77 + | aiFortranVersion ai == Fortran77Legacy && posColumn _position > 72 && _curChar /= '\n' + = skip Comment ai -- Read genuine character and advance. Also covers white sensitivity. | otherwise = let (_b:_bs) = utf8Encode _curChar in diff --git a/src/Language/Fortran/Parser/Any.hs b/src/Language/Fortran/Parser/Any.hs --- a/src/Language/Fortran/Parser/Any.hs +++ b/src/Language/Fortran/Parser/Any.hs @@ -2,7 +2,8 @@ import Language.Fortran.AST import Language.Fortran.Util.ModFile -import Language.Fortran.ParserMonad (FortranVersion(..), ParseErrorSimple(..), fromParseResult) +import Language.Fortran.Version (FortranVersion(..), deduceFortranVersion) +import Language.Fortran.ParserMonad (ParseErrorSimple(..), fromParseResult) import Language.Fortran.Parser.Fortran66 ( fortran66Parser, fortran66ParserWithModFiles ) import Language.Fortran.Parser.Fortran77 ( fortran77Parser, fortran77ParserWithModFiles @@ -13,25 +14,7 @@ import Language.Fortran.Parser.Fortran2003 ( fortran2003Parser, fortran2003ParserWithModFiles ) import qualified Data.ByteString.Char8 as B -import Data.Char (toLower) -import Data.List (isSuffixOf) -deduceVersion :: String -> FortranVersion -deduceVersion path - | isExtensionOf ".f" = Fortran77Extended - | isExtensionOf ".for" = Fortran77 - | isExtensionOf ".fpp" = Fortran77 - | isExtensionOf ".ftn" = Fortran77 - | isExtensionOf ".f90" = Fortran90 - | isExtensionOf ".f95" = Fortran95 - | isExtensionOf ".f03" = Fortran2003 - | isExtensionOf ".f2003" = Fortran2003 - | isExtensionOf ".f08" = Fortran2008 - | isExtensionOf ".f2008" = Fortran2008 - | otherwise = Fortran90 -- default - where - isExtensionOf = flip isSuffixOf $ map toLower path - type Parser = B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserVersions :: [(FortranVersion, Parser)] parserVersions = @@ -61,14 +44,14 @@ -- contents of the file. fortranParser :: Parser fortranParser contents filename = do - let Just parserF = lookup (deduceVersion filename) parserVersions + let Just parserF = lookup (deduceFortranVersion filename) parserVersions parserF contents filename -- | Deduce the type of parser from the filename and parse the -- contents of the file, within the context of given "mod files". fortranParserWithModFiles :: ParserWithModFiles fortranParserWithModFiles mods contents filename = do - let Just parserF = lookup (deduceVersion filename) parserWithModFilesVersions + let Just parserF = lookup (deduceFortranVersion filename) parserWithModFilesVersions parserF mods contents filename -- | Given a FortranVersion, parse the contents of the file. diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y --- a/src/Language/Fortran/Parser/Fortran77.y +++ b/src/Language/Fortran/Parser/Fortran77.y @@ -515,28 +515,30 @@ STRUCTURE_DECLARATIONS :: { [StructureItem A0] } STRUCTURE_DECLARATIONS : STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT - { $2 : $1 } -| STRUCTURE_DECLARATION_STATEMENT { [ $1 ] } + { if isNothing $2 then $1 else fromJust $2 : $1 } +| STRUCTURE_DECLARATION_STATEMENT { if isNothing $1 then [] else [fromJust $1] } -STRUCTURE_DECLARATION_STATEMENT :: { StructureItem A0 } +STRUCTURE_DECLARATION_STATEMENT :: { Maybe (StructureItem A0) } STRUCTURE_DECLARATION_STATEMENT : DECLARATION_STATEMENT NEWLINE { let StDeclaration () s t attrs decls = $1 - in StructFields () s t attrs decls } + in Just $ StructFields () s t attrs decls } | union NEWLINE UNION_MAPS endunion NEWLINE - { StructUnion () (getTransSpan $1 $5) (fromReverseList $3) } + { Just $ StructUnion () (getTransSpan $1 $5) (fromReverseList $3) } | structure MAYBE_NAME NAME NEWLINE STRUCTURE_DECLARATIONS endstructure NEWLINE - { StructStructure () (getTransSpan $1 $7) $2 $3 (fromReverseList $5) } + { Just $ StructStructure () (getTransSpan $1 $7) $2 $3 (fromReverseList $5) } +| comment NEWLINE { Nothing } UNION_MAPS :: { [ UnionMap A0 ] } UNION_MAPS -: UNION_MAPS UNION_MAP { $2 : $1 } -| UNION_MAP { [ $1 ] } +: UNION_MAPS UNION_MAP { if isNothing $2 then $1 else fromJust $2 : $1 } +| UNION_MAP { if isNothing $1 then [] else [fromJust $1] } -UNION_MAP :: { UnionMap A0 } +UNION_MAP :: { Maybe (UnionMap A0) } UNION_MAP : map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE - { UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } + { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } +| comment NEWLINE { Nothing } ENTRY_ARGS :: { AList Expression A0 } ENTRY_ARGS @@ -880,6 +882,7 @@ | NUMERIC_LITERAL { $1 } | '(' ARITHMETIC_CONSTANT_EXPRESSION ',' ARITHMETIC_CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)} | VARIABLE { $1 } +| SUBSCRIPT { $1 } RELATIONAL_OPERATOR :: { BinaryOp } RELATIONAL_OPERATOR @@ -1111,7 +1114,7 @@ fmap (pfSetFilename filename . transform) $ parse parseState where transform = transformWithModFiles mods transformations77Legacy - parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename + parseState = initParseState sourceCode Fortran77Legacy filename legacy77ParserWithIncludes :: [String] -> B.ByteString -> String -> IO (ParseResult AlexInput Token (ProgramFile A0)) @@ -1124,7 +1127,7 @@ p' <- descendBiM (inlineInclude Fortran77Legacy incs []) p return (ParseOk p' x) transform = transformWithModFiles emptyModFiles transformations77Legacy - parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename + parseState = initParseState sourceCode Fortran77Legacy filename includeParser :: FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0] @@ -1138,7 +1141,7 @@ inlineInclude fv dirs seen st = case st of StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do if notElem path seen then do - inc <- truncateLines <$> readInDirs dirs path + inc <- readInDirs dirs path case includeParser fv inc path of ParseOk blocks _ -> do blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks @@ -1155,9 +1158,6 @@ B.readFile (df) else readInDirs ds f - -truncateLines :: B.ByteString -> B.ByteString -truncateLines b = B.unlines . map (B.filter (/='\r') . B.take 72) . B.lines $ b parseError :: Token -> LexAction a parseError _ = do diff --git a/src/Language/Fortran/ParserMonad.hs b/src/Language/Fortran/ParserMonad.hs --- a/src/Language/Fortran/ParserMonad.hs +++ b/src/Language/Fortran/ParserMonad.hs @@ -5,9 +5,21 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE CPP #-} -module Language.Fortran.ParserMonad where +module Language.Fortran.ParserMonad + ( module Language.Fortran.ParserMonad + , module Language.Fortran.Version -- TODO: temporary plug to avoid API change + ) where +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fail (MonadFail) +#endif + +import Language.Fortran.Version + import GHC.IO.Exception import Control.Exception @@ -15,49 +27,12 @@ import Control.Monad.Except import Data.Typeable -import Data.Data -import GHC.Generics (Generic) import Language.Fortran.Util.Position -import Data.Char (toLower) -import Data.List (isInfixOf, find) ------------------------------------------------------------------------------- -- Helper datatype definitions ------------------------------------------------------------------------------- -data FortranVersion = Fortran66 - | Fortran77 - | Fortran77Extended - | Fortran77Legacy - | Fortran90 - | Fortran95 - | Fortran2003 - | Fortran2008 - deriving (Ord, Eq, Data, Typeable, Generic) - -instance Show FortranVersion where - show Fortran66 = "Fortran 66" - show Fortran77 = "Fortran 77" - show Fortran77Extended = "Fortran 77 Extended" - show Fortran77Legacy = "Fortran 77 Legacy" - show Fortran90 = "Fortran 90" - show Fortran95 = "Fortran 95" - show Fortran2003 = "Fortran 2003" - show Fortran2008 = "Fortran 2008" - -fortranVersionAliases :: [(String, FortranVersion)] -fortranVersionAliases = [ ("66" , Fortran66) - , ("77e", Fortran77Extended) - , ("77l", Fortran77Legacy) - , ("77" , Fortran77) - , ("90" , Fortran90) - , ("95" , Fortran95) - , ("03" , Fortran2003) - , ("08" , Fortran2008) ] - -selectFortranVersion :: String -> Maybe FortranVersion -selectFortranVersion alias = snd <$> find (\ entry -> fst entry `isInfixOf` map toLower alias) fortranVersionAliases - data ParanthesesCount = ParanthesesCount { pcActual :: Integer , pcHasReached0 :: Bool } @@ -147,6 +122,12 @@ ParseOk a s' -> unParse (f a) s' ParseFailed e -> ParseFailed e +#if !MIN_VERSION_base(4,13,0) + -- Monad(fail) was removed in GHC 8.8.1 + fail = Fail.fail +#endif + +instance (Loc b, LastToken b c, Show c) => MonadFail (Parse b c) where fail msg = Parse $ \s -> ParseFailed ParseError { errPos = (getPos . psAlexInput) s , errLastToken = (getLastToken . psAlexInput) s diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -46,7 +46,7 @@ overlay top bottom = text $ top' ++ drop (length top') (render bottom) where top' = render top -fixedForm :: Maybe Int +fixedForm :: Indentation fixedForm = Just 6 pprintAndRender :: IndentablePretty t => FortranVersion -> t -> Indentation -> String @@ -386,9 +386,9 @@ | v < Fortran90 = case (mLenSel, mKindSel) of (Just lenSel, Nothing) -> - char '*' <+> parens (pprint' Fortran77Extended lenSel) + char '*' <> noParensLit lenSel (Nothing, Just kindSel) -> - char '*' <+> parens (pprint' Fortran77Extended kindSel) + char '*' <> noParensLit kindSel _ -> error "Kind and length selectors can be active one at a time in\ \Fortran 77." @@ -404,6 +404,8 @@ where len e = "len=" <> pprint' v e kind e = "kind=" <> pprint' v e + noParensLit e@(ExpValue _ _ (ValInteger _)) = pprint' v e + noParensLit e = parens $ pprint' v e instance Pretty (Statement a) where pprint' v (StDeclaration _ _ typeSpec mAttrList declList) @@ -994,7 +996,9 @@ case mInit of Nothing -> pprint' v e <> char '*' pprint' v mLen - _ -> tooOld v "Variable initialisation" Fortran90 + Just initial -> pprint' v e <> + char '*' pprint' v mLen <> + char '/' <> pprint' v initial <> char '/' pprint' v (DeclVariable _ _ e mLen mInit) | Nothing <- mLen @@ -1013,7 +1017,14 @@ case mInit of Nothing -> pprint' v e <> parens (pprint' v dims) <> "*" pprint' v mLen - _ -> tooOld v "Variable initialisation" Fortran90 + Just initial -> + let initDoc = case initial of + ExpInitialisation _ _ es -> + char '/' <> pprint' v es <> char '/' + e' -> pprint' v e' + in pprint' v e <> parens (pprint' v dims) <> + "*" pprint' v mLen <> initDoc + pprint' v (DeclArray _ _ e dims mLen mInit) | Nothing <- mLen , Nothing <- mInit = pprint' v e <> parens (pprint' v dims) @@ -1062,3 +1073,66 @@ commaSep :: [Doc] -> Doc commaSep = hcat . punctuate ", " + +data ReformatState + -- | Unsure yet whether current line it's a comment or statement. + = RefmtStNewline Int + + -- | Current line is a comment; no need to track column number. + | RefmtStComment + + -- | Current line is a statement. + | RefmtStStmt Int + deriving (Eq, Ord, Show) + +-- | Add continuations where required to a pretty-printed program. +-- +-- Ensures that no non-comment line exceeds 72 columns. +-- +-- The reformatting should be compatible with fixed and free-form Fortran +-- standards. See: http://fortranwiki.org/fortran/show/Continuation+lines +-- +-- This is a simple, delicate algorithm that must only be used on pretty printer +-- output, due to relying on particular parser & pretty printer behaviour. In +-- particular, comments not beginning a line (e.g. after a statement or +-- continuation) won't be picked up as a comment, so could wreck that line. Be +-- warned if you're using it on piles of funky-looking code! +reformatMixedFormInsertContinuations :: String -> String +reformatMixedFormInsertContinuations = go stNewline + where + go :: ReformatState -> String -> String + + -- all states: end on empty, break on newline + go _ [] = [] + go _ ('\n':xs) = '\n' : go stNewline xs + + -- in comment: skip + go RefmtStComment (x:xs) = x : go RefmtStComment xs + + -- newline F77 override: if 'c' in first column, it's a comment + go (RefmtStNewline 0) ('c':xs) = 'c' : go RefmtStComment xs + + -- line type uncertain: consume up to non-space, then decide + go (RefmtStNewline col) (x:xs) = + case x of + ' ' -> ' ' : go (RefmtStNewline (col+1)) xs + '!' -> '!' : go RefmtStComment xs + _ -> x : go (RefmtStStmt (col+1)) xs + + -- in statement: break when required + go (RefmtStStmt col) (x:xs) + | col == maxCol = + -- lookahead: if next is newline or EOF, we don't need to break + case xs of + [] -> x : go (RefmtStStmt (col+1)) xs + x':_ -> + case x' of + '\n' -> x : go (RefmtStStmt (col+1)) xs + _ -> + -- pretend to continue, but we know that we'll break + -- on newline next + '&' : go (RefmtStStmt (col+1)) ("\n &" ++ x:xs) + | otherwise = x : go (RefmtStStmt (col+1)) xs + + maxCol = 72 + stNewline = RefmtStNewline 0 diff --git a/src/Language/Fortran/Rewriter.hs b/src/Language/Fortran/Rewriter.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Rewriter.hs @@ -0,0 +1,135 @@ +-- | This module provides an interface for rewriting textual, unparsed Fortran +-- using a diff-like algorithm. +-- +-- Original code from Bloomberg, used with permission. +-- +-- Original authors: +-- * Daniel Beer +-- * Anthony Burzillo +-- * Raoul Hidalgo Charman +-- * Aiden Jeffrey +-- * Jason Xu +-- * Beleth Apophis +-- * Lukasz Kolodziejczyk + +module Language.Fortran.Rewriter + ( RI.SourceLocation(..) + , RI.SourceRange(..) + , RI.Replacement(..) + , RI.ReplacementError(..) + , RI.ReplacementMap + , partitionOverlapping + , processReplacements + , spanToSourceRange + , spanToSourceRange2 + , sourceRangeBetweenTwoSpans + ) +where + +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Language.Fortran.Rewriter.Internal + as RI +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.IO.Temp ( withTempDirectory ) + +-- | Remove overlapping items from a list of replacements and return a pair of +-- lists containing disjoint items and overlapping items, respectively. +-- +-- __Important notes:__ +-- +-- Replacements that come first in the list will be given precedence over later +-- 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) + +-- | Apply a list of 'Replacement's to the orginal source file. +-- +-- __Important notes:__ +-- +-- Source locations specified in replacements are 0-indexed. +-- +-- Rewriting applies continuation lines when lines are longer than 72 characters. +-- +-- __Example replacements:__ +-- +-- Delete the first character in a file +-- +-- @ Replacement (SourceRange (SourceLocation 0 0) (SourceLocation 0 1)) "" @ +-- +-- Prepend "a" to 1 line, 2 column character +-- +-- @ Replacement (SourceRange (SourceLocation 0 1) (SourceLocation 0 1)) "a" @ +-- +-- Replace a character located in 2 line, 4 column with "a" +-- +-- @ Replacement (SourceRange (SourceLocation 1 3) (SourceLocation 1 4)) "a" @ +-- +-- Replace string starting in 2 line, 4 column and ending in 2 line, 6 column (inclusive) with "a" +-- +-- @ Replacement (SourceRange (SourceLocation 1 3) (SourceLocation 1 6)) "a" @ +-- +-- @since 0.1.0.0 +processReplacements :: RI.ReplacementMap -> IO () +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 putStrLn tmpFile + BC.writeFile tmpFile newContents + renameFile tmpFile filePath + +-- | Utility function to convert 'SrcSpan' to 'SourceRange' +-- +-- @since 0.1.13.7 +spanToSourceRange :: SrcSpan -> RI.SourceRange +spanToSourceRange (SrcSpan start end) = + let (l1, c1) = lineCol start + (l2, c2) = lineCol end + in RI.SourceRange (RI.SourceLocation (l1 - 1) (c1 - 1)) + (RI.SourceLocation (l2 - 1) c2) + +-- | Given two 'Span's, returns a 'SourceRange' that starts at the starting +-- location of the first span, and ends at the starting location of the second +-- span +-- +-- @since 0.1.17.2 +spanToSourceRange2 :: SrcSpan -> SrcSpan -> RI.SourceRange +spanToSourceRange2 (SrcSpan start1 _) (SrcSpan start2 _) = + let (l1, c1) = lineCol start1 + (l2, c2) = lineCol start2 + in RI.SourceRange (RI.SourceLocation (l1 - 1) (c1 - 1)) + (RI.SourceLocation (l2 - 1) (c2 - 1)) + +-- | Given two 'Span's, returns a 'SourceRange' that starts at the ending +-- location of the first span, and ends at the starting location of the second +-- span +-- +-- @since 0.1.17.2 +sourceRangeBetweenTwoSpans :: SrcSpan -> SrcSpan -> RI.SourceRange +sourceRangeBetweenTwoSpans (SrcSpan _ end1) (SrcSpan start2 _) = + let (l1, c1) = lineCol end1 + (l2, c2) = lineCol start2 + in RI.SourceRange (RI.SourceLocation (l1 - 1) c1) + (RI.SourceLocation (l2 - 1) (c2 - 1)) diff --git a/src/Language/Fortran/Rewriter/Internal.hs b/src/Language/Fortran/Rewriter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Rewriter/Internal.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Original code from Bloomberg, used with permission. +-- +-- Original authors: +-- * Daniel Beer +-- * Anthony Burzillo +-- * Raoul Hidalgo Charman +-- * Aiden Jeffrey +-- * Jason Xu +-- * Beleth Apophis +-- * Lukasz Kolodziejczyk + +module Language.Fortran.Rewriter.Internal where + +import Data.Int +import Data.ByteString.Lazy.Char8 ( ByteString ) +import qualified Data.ByteString.Lazy.Char8 as BC +import Control.Exception ( Exception + , throw + ) +import Data.List ( sort + , find + ) +import Data.Maybe ( isNothing + , fromMaybe + , fromJust + , maybeToList + ) +import qualified Data.Map as M +import Data.Typeable ( Typeable ) + +-- | Represents location in source code. +-- +-- Note that, 'SourceLocation' indicates space between characters, +-- i.e the following example: +-- +-- @ SourceLocation 0 1 @ +-- +-- indicates position between first and second characters in a file. +data SourceLocation = SourceLocation Int Int deriving (Show, Eq) + +-- | Represents range in source code. +data SourceRange = SourceRange SourceLocation SourceLocation deriving (Eq) +instance Show SourceRange where + show (SourceRange (SourceLocation l1 c1) (SourceLocation l2 c2)) = + "(" + ++ show (l1 + 1) ++ ":" ++ show (c1 + 1) + ++ ")-(" + ++ show (l2 + 1) ++ ":" ++ show (c2 + 1) + ++ ")" + +-- | Represents a character in the original source text along with +-- any replacement operations applied to the character in place. +-- +-- It expects a character (in case it's empty, Nothing should be used), +-- whether it should be removed, its 'SourceLocation' and a string that +-- should be put in place of it. +data RChar = RChar (Maybe Char) Bool SourceLocation ByteString deriving (Show, Eq) + +-- | Represents the intent to replace content in the file. +-- +-- The content in 'Replacement' will be used in place of what is in +-- the range described. Note that the replacement text can be shorter +-- or larger than the original span, and it can also be multi-line. +data Replacement = Replacement SourceRange String deriving (Show, Eq) +instance Ord Replacement where + (Replacement (SourceRange a _) _) <= (Replacement (SourceRange b _) _) = + a < b + +-- | Exception raised when two 'Replacement' objects overlap +-- ('OverlappingError') or 'Replacement' points at invalid locations +-- ('InvalidRangeError'). +data ReplacementError + = OverlappingError [(Replacement, Replacement)] + | InvalidRangeError + deriving (Show, Typeable, Eq) + +-- | As we advance through the ['RChar'] list, we consider "chunks" +-- as the unit of text written out. A chunk is either: +-- +-- 1. original source text up to a newline character, end of file +-- or 'RChar' described in 2. +-- 2. a single 'RChar' that has non-empty replacement string +-- or is deleted. +type Chunk = [RChar] + +-- | Represents map of files and replacements that will be done. +type ReplacementMap = M.Map String [Replacement] + +instance Exception ReplacementError +instance Ord SourceLocation where + (SourceLocation l1 c1) <= (SourceLocation l2 c2) = + l1 < l2 || l1 == l2 && c1 <= c2 + +-- | Parses input string into a list of annotated characters. +toRCharList :: ByteString -> [RChar] +toRCharList = reverse . uncurry appendLast . BC.foldl' + go + (SourceLocation 0 0, []) + where + go :: (SourceLocation, [RChar]) -> Char -> (SourceLocation, [RChar]) + go (loc@(SourceLocation line col), rcs) c = + let newLoc = if c /= '\n' + then SourceLocation line (col + 1) + else SourceLocation (line + 1) 0 + in (newLoc, RChar (Just c) False loc "" : rcs) + appendLast loc = (RChar Nothing False loc "" :) + +-- | Marks 'RChars' in a given range to be removed later. +markRChars :: [RChar] -> SourceRange -> [RChar] +markRChars rchars sr = markRChars_ rchars sr (SourceLocation 0 0) + +markRChars_ :: [RChar] -> SourceRange -> SourceLocation -> [RChar] +markRChars_ [] _ _ = [] +markRChars_ (RChar x odel _ orepl : xs) sr@(SourceRange (SourceLocation sl sc) (SourceLocation el ec)) (SourceLocation l c) = + rch : rchs + where + rch = + if l == sl && l == el && c >= sc && c < ec + || l == sl && l < el && c >= sc + || l == el && l > sl && c < ec + || l > sl && l < el + then RChar x True (SourceLocation l c) "" + else RChar x odel (SourceLocation l c) orepl + rchs = + if x /= Just '\n' + then markRChars_ xs sr (SourceLocation l (c + 1)) + else markRChars_ xs sr (SourceLocation (l + 1) 0) + +-- | Sets replacement string to be prepended to the given location. +setReplacementStringSL + :: [RChar] -> SourceLocation -> ByteString -> Bool -> [RChar] +setReplacementStringSL [] _ _ _ = [] +setReplacementStringSL (RChar och odel osl@(SourceLocation ol oc) orepl : xs) sl@(SourceLocation l c) repl isInsert + = if l == ol && c == oc + then if isInsert + then + RChar och + odel + osl + -- (repl <> if isNothing och then "" else [fromJust och]) + (repl <> maybe "" BC.singleton och) + : xs + else RChar och odel osl repl : xs + else RChar och odel osl orepl : setReplacementStringSL xs sl repl isInsert + +-- | Sets replacement string to be prepended to the begining of the +-- given range. +setReplacementStringSR + :: [RChar] -> SourceRange -> ByteString -> Bool -> [RChar] +setReplacementStringSR rchars (SourceRange sls _) = + setReplacementStringSL rchars sls + +-- | Applies all deletions and additions and transforms 'RChars' back +-- to a string. +evaluateRChars :: [RChar] -> ByteString +evaluateRChars = BC.concat . map evaluateRChar + +-- | If 'RChar' is marked as deleted, it'll be evaluated to its +-- replacement string, otherwise original character will be returned. +evaluateRChar :: RChar -> ByteString +evaluateRChar (RChar char del _ repl) | del = repl + | isNothing char = "" + | otherwise = BC.singleton $ fromJust char + +-- | From ['RChar'], obtain a ('Chunk', ['RChars']) where the 'Chunk' +-- is the next 'Chunk' and the ['RChar'] are the remaining 'RChar's. +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) + where rec = nextChunk xs +nextChunk (rchar@(RChar _ True _ _) : xs) = ([rchar], xs) +nextChunk rchars = nextChunk_ rchars + +nextChunk_ :: [RChar] -> (Chunk, [RChar]) +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 + +-- | Splits ['RChar'] into 'Chunk's. +allChunks :: [RChar] -> [Chunk] +allChunks [] = [] +allChunks rchars = chunk : allChunks rest + where (chunk, rest) = nextChunk rchars + +-- | Transform a list of 'Chunk's into a single string, applying +-- continuation lines when neccessary. +evaluateChunks :: [Chunk] -> ByteString +evaluateChunks ls = evaluateChunks_ ls 0 + +evaluateChunks_ :: [Chunk] -> Int64 -> ByteString +evaluateChunks_ [] _ = "" +evaluateChunks_ (x : xs) currLen = + if overLength + then "\n +" + <> evaluateRChars xPadded + <> maybe (evaluateChunks_ xs (6 + nextLen)) (evaluateChunks_ xs) + lastLen + else chStr + <> maybe (evaluateChunks_ xs (currLen + nextLen)) (evaluateChunks_ xs) + lastLen + where + overLength = currLen + nextLen > 72 && currLen > 0 + xPadded = padImplicitComments x (72 - 6) + chStr = evaluateRChars x + nextLen = fromMaybe + (BC.length chStr) + (myMin (BC.elemIndex '\n' chStr) (BC.elemIndex '!' chStr)) -- 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 + -- Text after line 72 is an implicit comment, so should stay there + 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 + where + findCommentRChar :: Chunk -> Maybe (Int, RChar) + findCommentRChar = + find ((\(RChar _ _ (SourceLocation _ cl) _) -> cl == 72) . snd) + . zip [1 ..] + padCommentRChar :: RChar -> Int -> RChar + padCommentRChar (RChar char _ loc repl) padding = RChar + char + True + loc + (BC.pack (replicate padding ' ' ++ maybeToList char) `BC.append` repl) + + + +-- | Return TRUE iff the 'Replacement' constitutes a character +-- insertion. +isInsertion :: Replacement -> Bool +isInsertion (Replacement (SourceRange (SourceLocation sl sc) (SourceLocation el ec)) repl) + = sl == el && sc == ec && repl /= "" + +insertionSR :: SourceRange -> SourceRange +insertionSR (SourceRange (SourceLocation sl sc) _) = + SourceRange (SourceLocation sl sc) (SourceLocation sl (sc + 1)) + +-- | Sets a single 'Replacement' given a list of 'RChar's. +setReplacement :: [RChar] -> Replacement -> [RChar] +setReplacement rchars repl@(Replacement sr replS) = + let replBS = BC.pack replS + in if isInsertion repl + then setReplacementStringSR (markRChars rchars (insertionSR sr)) + (insertionSR sr) + replBS + True + else setReplacementStringSR (markRChars rchars sr) sr replBS False + +-- | Sets a list of 'Replacement's given a list of 'RChar's. +setReplacements :: [RChar] -> [Replacement] -> [RChar] +setReplacements rchars repls = + let rchar' = foldl setReplacement rchars repls in adjustLineWrap rchar' + + +-- | heuristic to wrap line after comma or right parenthesis if applicable +adjustLineWrap :: [RChar] -> [RChar] +adjustLineWrap [] = [] +adjustLineWrap [x] = [x] +adjustLineWrap (rc@(RChar _ True _ _) : rs@(RChar (Just c) False _ _ : _)) + | c `elem` [',', ')'] = adjustLineWrapAux rc [] rs +adjustLineWrap (x : xs) = x : adjustLineWrap xs + + +adjustLineWrapAux :: RChar -> [RChar] -> [RChar] -> [RChar] +adjustLineWrapAux rc1 deleted (rc2@(RChar (Just c) False _ _) : rs) + | c `elem` [',', ')'] = adjustLineWrapAux (appendRC rc1 c) + (deleteRC rc2 : deleted) + rs +adjustLineWrapAux rc1 deleted rs = (rc1 : reverse deleted) <> adjustLineWrap rs + + +-- | Mark removal for the input 'RChar' +deleteRC :: RChar -> RChar +deleteRC (RChar _ _ loc s) = RChar Nothing True loc s + + +-- | Append the input character to the replacement string +appendRC :: RChar -> Char -> RChar +appendRC (RChar mc _ loc s) c = RChar mc True loc (s `BC.snoc` c) + + +-- | Checks whether two 'Replacement's are not overlapping. +areDisjoint :: Replacement -> Replacement -> Bool +areDisjoint (Replacement (SourceRange (SourceLocation r1sl r1sc) (SourceLocation r1el r1ec)) _) (Replacement (SourceRange (SourceLocation r2sl r2sc) (SourceLocation r2el r2ec)) _) + | r2sl > r1el || r1sl > r2el = True + | r1el == r2sl && r1ec <= r2sc = True + | r1sl == r2el && r1sc >= r2ec = True + | otherwise = False + +-- | Checks whether: +-- +-- 1. the start is before the end of the range and +-- 2. both start and end locations are within the code. +isValidRange :: SourceRange -> [RChar] -> Bool +isValidRange (SourceRange sl1 sl2) rchars = + sl1 <= sl2 && isValidLocation sl1 rchars && isValidLocation sl2 rchars + +isValidLocation :: SourceLocation -> [RChar] -> Bool +isValidLocation _ [] = False +isValidLocation sl (RChar _ _ csl _ : xs) = sl == csl || isValidLocation sl xs + +checkRanges :: [RChar] -> [Replacement] -> [RChar] +checkRanges rchars repls = if and validList + then rchars + else throw InvalidRangeError + where validList = [ isValidRange sr rchars | (Replacement sr _) <- repls ] + +checkOverlapping :: [Replacement] -> [Replacement] +checkOverlapping repls = if null overlappingPairs + then repls + else throw $ OverlappingError overlappingPairs + where + overlappingPairs = findOverlappingPairs (sort repls) + + findOverlappingPairs :: [Replacement] -> [(Replacement, Replacement)] + findOverlappingPairs [] = [] + findOverlappingPairs repls' = + let currentRepl = head repls' + overlapping = takeWhile (not . areDisjoint currentRepl) (tail repls') + nextResult = findOverlappingPairs (tail repls') + in [ (currentRepl, x) | x <- overlapping ] <> nextResult + +-- | Applies 'Replacement's to a string and return it. +-- +-- Firstly, it transforms the string into a list of 'RChar's. +-- +-- After that, it validates the 'SourceRange' of each 'Replacement'. +-- +-- In the end, it splits up 'RChar's in 'Chunk's, set the +-- 'Replacement's and evaluates the 'Chunk's. +applyReplacements :: ByteString -> [Replacement] -> ByteString +applyReplacements str repls = applyReplacements_ (checkRanges rchars repls) + (checkOverlapping repls) + where rchars = toRCharList str + +applyReplacements_ :: [RChar] -> [Replacement] -> ByteString +applyReplacements_ rchars repls = evaluateChunks chunks + where + replRchars = setReplacements rchars repls + chunks = allChunks replRchars diff --git a/src/Language/Fortran/Util/Files.hs b/src/Language/Fortran/Util/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Util/Files.hs @@ -0,0 +1,41 @@ +module Language.Fortran.Util.Files + ( flexReadFile + , getDirContents + , rGetDirContents + ) where + +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.ByteString.Char8 as B +import System.Directory (listDirectory, canonicalizePath, + doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) +import Data.List ((\\)) + +-- | Obtain a UTF-8 safe 'B.ByteString' representation of a file's contents. +-- +-- Invalid UTF-8 is replaced with the space character. +flexReadFile :: FilePath -> IO B.ByteString +flexReadFile = fmap (T.encodeUtf8 . T.decodeUtf8With (T.replace ' ')) . B.readFile + +-- | List files in directory, with the directory prepended to each entry. +getDirContents :: FilePath -> IO [FilePath] +getDirContents d = do + d' <- canonicalizePath d + map (d' ) `fmap` listDirectory d' + +-- | List files in directory recursively. +rGetDirContents :: FilePath -> IO [FilePath] +rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d' + where + go seen d'' = do + ds <- getDirectoryContents d'' + fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries + where + f x = do + path <- canonicalizePath $ d ++ "/" ++ x + g <- doesDirectoryExist path + if g && notElem path seen then do + x' <- go (path : seen) path + return $ map (\ y -> x ++ "/" ++ y) x' + else return [x] diff --git a/src/Language/Fortran/Util/Position.hs b/src/Language/Fortran/Util/Position.hs --- a/src/Language/Fortran/Util/Position.hs +++ b/src/Language/Fortran/Util/Position.hs @@ -9,7 +9,6 @@ import Text.PrettyPrint.GenericPretty import Text.PrettyPrint import Data.Binary -import GHC.Generics (Generic) import Control.DeepSeq import Language.Fortran.Util.SecondParameter diff --git a/src/Language/Fortran/Version.hs b/src/Language/Fortran/Version.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Version.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +-- | Fortran version enum and tools for selecting version for a given file. + +module Language.Fortran.Version + ( FortranVersion(..) + , fortranVersionAliases + , selectFortranVersion + , deduceFortranVersion + , deduceVersion -- deprecated + ) where + +import Data.Char (toLower) +import Data.List (isInfixOf, isSuffixOf, find) + +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) + +data FortranVersion = Fortran66 + | Fortran77 + | Fortran77Extended + | Fortran77Legacy + | Fortran90 + | Fortran95 + | Fortran2003 + | Fortran2008 + deriving (Ord, Eq, Data, Typeable, Generic) + +instance Show FortranVersion where + show Fortran66 = "Fortran 66" + show Fortran77 = "Fortran 77" + show Fortran77Extended = "Fortran 77 Extended" + show Fortran77Legacy = "Fortran 77 Legacy" + show Fortran90 = "Fortran 90" + show Fortran95 = "Fortran 95" + show Fortran2003 = "Fortran 2003" + show Fortran2008 = "Fortran 2008" + +fortranVersionAliases :: [(String, FortranVersion)] +fortranVersionAliases = [ ("66" , Fortran66) + , ("77e", Fortran77Extended) + , ("77l", Fortran77Legacy) + , ("77" , Fortran77) + , ("90" , Fortran90) + , ("95" , Fortran95) + , ("03" , Fortran2003) + , ("08" , Fortran2008) ] + +selectFortranVersion :: String -> Maybe FortranVersion +selectFortranVersion alias = snd <$> find (\ entry -> fst entry `isInfixOf` map toLower alias) fortranVersionAliases + +-- | Deduce the 'FortranVersion' from a 'FilePath' using extension. +-- +-- Defaults to Fortran 90 if suffix is unrecognized. +deduceFortranVersion :: FilePath -> FortranVersion +deduceFortranVersion path + | isExtensionOf ".f" = Fortran77Extended + | isExtensionOf ".for" = Fortran77 + | isExtensionOf ".fpp" = Fortran77 + | isExtensionOf ".ftn" = Fortran77 + | isExtensionOf ".f90" = Fortran90 + | isExtensionOf ".f95" = Fortran95 + | isExtensionOf ".f03" = Fortran2003 + | isExtensionOf ".f2003" = Fortran2003 + | isExtensionOf ".f08" = Fortran2008 + | isExtensionOf ".f2008" = Fortran2008 + | otherwise = Fortran90 -- unrecognized, default to F90 + where + isExtensionOf = flip isSuffixOf $ map toLower path + +-- | Alias for previous function name. TODO: deprecate eventually. +deduceVersion :: FilePath -> FortranVersion +deduceVersion = deduceFortranVersion diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -6,8 +6,7 @@ import Prelude hiding (readFile, mod) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (replace) +import Language.Fortran.Util.Files import Text.PrettyPrint (render) @@ -18,18 +17,19 @@ import System.FilePath import Text.PrettyPrint.GenericPretty (pp, pretty, Out) import Text.Read (readMaybe) -import Data.List (sortBy, intercalate, (\\), isSuffixOf) +import Data.List (sortBy, intercalate, isSuffixOf) import Data.Ord (comparing) import Data.Char (toLower) import Data.Maybe (listToMaybe, fromMaybe, maybeToList) import Data.Data import Data.Generics.Uniplate.Data -import Language.Fortran.ParserMonad (selectFortranVersion, FortranVersion(..), fromRight) +import Language.Fortran.Version (FortranVersion(..), selectFortranVersion, deduceFortranVersion) +import Language.Fortran.ParserMonad (fromRight) import qualified Language.Fortran.Lexer.FixedForm as FixedForm (collectFixedTokens, Token(..)) import qualified Language.Fortran.Lexer.FreeForm as FreeForm (collectFreeTokens, Token(..)) -import Language.Fortran.Parser.Any +import Language.Fortran.Parser.Any (parserWithModFilesVersions) import Language.Fortran.Util.ModFile import Language.Fortran.Util.Position @@ -104,7 +104,7 @@ mapM_ (\ p -> compileFileToMod (fortranVersion opts) mods p (outputFile opts)) paths (path:_, actionOpt) -> do contents <- flexReadFile path - let version = fromMaybe (deduceVersion path) (fortranVersion opts) + let version = fromMaybe (deduceFortranVersion path) (fortranVersion opts) let (Just parserF0) = lookup version parserWithModFilesVersions let parserF m b s = fromRight (parserF0 m b s) let outfmt = outputFormat opts @@ -139,7 +139,12 @@ Rename -> pp . runRenamer $ parserF mods contents path BBlocks -> putStrLn . runBBlocks $ parserF mods contents path SuperGraph -> putStrLn . runSuperGraph $ parserF mods contents path - Reprint -> putStrLn . render . flip (pprint version) (Just 0) $ parserF mods contents path + Reprint -> + let prettyContents = render . flip (pprint version) (Just 0) $ parserF mods contents path + in putStrLn $ + if useContinuationReformatter opts + then reformatMixedFormInsertContinuations prettyContents + else prettyContents DumpModFile -> do let path' = if modFileSuffix `isSuffixOf` path then path else path <.> modFileSuffix contents' <- LB.readFile path' @@ -238,7 +243,7 @@ compileFileToMod :: Maybe FortranVersion -> ModFiles -> FilePath -> Maybe FilePath -> IO ModFile compileFileToMod mvers mods path moutfile = do contents <- flexReadFile path - let version = fromMaybe (deduceVersion path) mvers + let version = fromMaybe (deduceFortranVersion path) mvers let (Just parserF0) = lookup version parserWithModFilesVersions let parserF m b s = fromRight (parserF0 m b s) let mmap = combinedModuleMap mods @@ -249,28 +254,6 @@ LB.writeFile fspath $ encodeModFile [mod] return mod --- List files in dir recursively -rGetDirContents :: String -> IO [String] -rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d' - where - go seen d'' = do - ds <- getDirectoryContents d'' - fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries - where - f x = do - path <- canonicalizePath $ d ++ "/" ++ x - g <- doesDirectoryExist path - if g && notElem path seen then do - x' <- go (path : seen) path - return $ map (\ y -> x ++ "/" ++ y) x' - else return [x] - --- List files in dir -getDirContents :: String -> IO [String] -getDirContents d = do - d' <- canonicalizePath d - map (d' ) `fmap` listDirectory d' - decodeModFiles :: [String] -> IO ModFiles decodeModFiles = flip foldM emptyModFiles $ \ modFiles d -> do -- Figure out the camfort mod files and parse them. @@ -374,10 +357,12 @@ , action :: Action , outputFormat :: OutputFormat , outputFile :: Maybe FilePath - , includeDirs :: [String] } + , includeDirs :: [String] + , useContinuationReformatter :: Bool + } initOptions :: Options -initOptions = Options Nothing Parse Default Nothing [] +initOptions = Options Nothing Parse Default Nothing [] False options :: [OptDescr (Options -> Options)] options = @@ -410,6 +395,10 @@ (NoArg $ \ opts -> opts { action = Reprint }) "Parse and output using pretty printer" , Option [] + ["split-long"] + (NoArg $ \ opts -> opts { useContinuationReformatter = True }) + "when using pretty printer, split long lines via continuations" + , Option [] ["dot"] (NoArg $ \ opts -> opts { outputFormat = DOT }) "output graphs in GraphViz DOT format" @@ -489,6 +478,3 @@ xs'' -> [ show xs'' ] isNewline (FreeForm.TNewline _) = True isNewline _ = False - -flexReadFile :: String -> IO B.ByteString -flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile diff --git a/test/Language/Fortran/Lexer/FixedFormSpec.hs b/test/Language/Fortran/Lexer/FixedFormSpec.hs --- a/test/Language/Fortran/Lexer/FixedFormSpec.hs +++ b/test/Language/Fortran/Lexer/FixedFormSpec.hs @@ -255,6 +255,29 @@ , TEndStructure u, TNewline u , TEOF u ] + it "lexes but skips comments after 72" $ do + let src = unlines [ " l = r" <> replicate 65 ' ' <> "! comment after 72" + , " r = l" + , replicate 72 ' ' <> "blank line with comment"] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe` + resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u + , TId u "r", TOpAssign u, TId u "l", TNewline u + , TNewline u, TEOF u] + it "lexes comment overflow" $ do + let src = unlines + [ " l = r" <> replicate 65 ' ' <> "Comment overflowing 72 limit" + , " r = l" + ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe` + resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u + , TId u "r", TOpAssign u, TId u "l", TNewline u, TEOF u] + it "lexel comment line overflow" $ do + let src = unlines [ replicate 80 'c' + , " l = r" ] + resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe` + resetSrcSpan [ TComment u (replicate 71 'c'), TNewline u + , TId u "l", TOpAssign u, TId u "r", TNewline u, TEOF u] + example1 :: String example1 = unlines [ " intEGerix", diff --git a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs --- a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +++ b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs @@ -206,6 +206,14 @@ st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) sParser " character a*8" `shouldBe'` st + it "parses 'character c*(ichar('A'))" $ do + let args = AList () u [ IxSingle () u Nothing (ExpValue () u (ValString "A")) ] + lenExpr = ExpSubscript () u (ExpValue () u (ValVariable "ichar")) args + decl = DeclVariable () u (varGen "c") (Just $ lenExpr) Nothing + typeSpec = TypeSpec () u (TypeCharacter Nothing Nothing) Nothing + st = StDeclaration () u typeSpec Nothing (AList () u [ decl ]) + sParser " character c*(ichar('A'))" `shouldBe'` st + it "parses included files" $ do let decl = DeclVariable () u (varGen "a") Nothing Nothing typeSpec = TypeSpec () u TypeInteger Nothing @@ -225,6 +233,34 @@ , " real r" , " end map" , " end union" + , " end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [DeclVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [DeclVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses structure/union/map blocks with comments" $ do + let src = init + $ unlines [ " structure /foo/" + , "C comment before union" + , " union" + , "C comment inside union, before map" + , " map" + , "C comment inside map" + , " integer i ! more comment" + , " end map" + , "C comment between maps" + , " map" + , " real r ! more comment" + , " end map" + , "C comment after map" + , " end union" + , "C comment after union" , " end structure"] ds = [ UnionMap () u $ AList () u [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs --- a/test/Language/Fortran/PrettyPrintSpec.hs +++ b/test/Language/Fortran/PrettyPrintSpec.hs @@ -5,9 +5,6 @@ module Language.Fortran.PrettyPrintSpec where import Prelude hiding (mod) -import qualified Data.ByteString.Char8 as B -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (replace) import Data.Data import Data.Generics.Uniplate.Operations @@ -18,7 +15,7 @@ import Language.Fortran.PrettyPrint import System.FilePath -import Text.PrettyPrint +import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint.GenericPretty import Test.Hspec @@ -54,7 +51,11 @@ describe "Selector" $ do it "prints Fortran 77 selector" $ do let sel = Selector () u (Just $ intGen 42) Nothing - pprint Fortran77 sel Nothing `shouldBe` "* (42)" + pprint Fortran77 sel Nothing `shouldBe` "*42" + let ksel = Selector () u Nothing (Just $ intGen 4) + pprint Fortran77 ksel Nothing `shouldBe` "*4" + let vsel = Selector () u (Just $ varGen "v") Nothing + pprint Fortran77 vsel Nothing `shouldBe` "*(v)" it "prints Fortran 90 selector" $ do let sel = Selector () u (Just $ intGen 42) (Just $ intGen 24) @@ -118,11 +119,13 @@ it "prints 77 style" $ do let typeSpec = TypeSpec () u TypeInteger Nothing - let dds = [ DimensionDeclarator () u Nothing (Just $ intGen 10) ] + let dds = [ DimensionDeclarator () u Nothing (Just $ intGen 5) ] let declList = - [ DeclArray () u (varGen "x") (AList () u dds) Nothing Nothing ] + [ DeclArray () u (varGen "x") (AList () u dds) Nothing + (Just . initGen $ map intGen [1..5]) + ] let st = StDeclaration () u typeSpec Nothing (AList () u declList) - pprint Fortran77 st Nothing `shouldBe` "integer x(10)" + pprint Fortran77 st Nothing `shouldBe` "integer x(5)/1, 2, 3, 4, 5/" describe "Intent" $ it "prints intent statement" $ do @@ -496,9 +499,42 @@ , "!hello!" ] pprint Fortran90 pf (Just 0) `shouldBe` text expect + describe "Continuation reformatting" $ do + it "continuates a too-long 77 style statement" $ do + let input = " integer, parameter :: " + <> "very_awfully_really_quite_pointlessly_long_s" + <> "illy_variable_name = 1" + expect = " integer, parameter :: " + <> "very_awfully_really_quite_pointlessly_long_s" + <> "&\n &" + <> "illy_variable_name = 1" + reformatMixedFormInsertContinuations input `shouldBe` expect + + it "does not continuate a long mixed-form comment line" $ do + let input = " ! a very long, long comment that ends up" + <> " exceeding both the F77 and F90 maximum line lengths" + <> " (~72 and ~132 respectively), but should not be" + <> " continuated (since they're ignored by compilers anyway)" + reformatMixedFormInsertContinuations input `shouldBe` input + + it "does not continuate a long F77 comment line" $ do + let input = "c F77 comments begin with a 'c' in the first column" + <> " position, so they're easy to handle" + reformatMixedFormInsertContinuations input `shouldBe` input + + it "adds continuations idempotently" $ do + let input = " integer, parameter :: " + <> "very_awfully_really_quite_pointlessly_long_s" + <> "illy_variable_name = 1" + pass1 = reformatMixedFormInsertContinuations input + pass2 = reformatMixedFormInsertContinuations pass1 + pass2 `shouldBe` pass1 + + it "does not continuate lines exactly 72 columns" $ do + let input = " integer, parameter :: " + <> "variable_id_making_line_exactly_72_chars = 1" + reformatMixedFormInsertContinuations input `shouldBe` input + valueExpressions :: Expression () -> Maybe (Expression ()) valueExpressions e@ExpValue{} = Just e valueExpressions _ = Nothing - -flexReadFile :: String -> IO B.ByteString -flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile diff --git a/test/Language/Fortran/Rewriter/InternalSpec.hs b/test/Language/Fortran/Rewriter/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Rewriter/InternalSpec.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fortran.Rewriter.InternalSpec + ( spec + ) +where + +import qualified Data.ByteString.Lazy.Char8 as BC +import Test.Hspec +import Control.Exception.Base ( evaluate ) +import Language.Fortran.Rewriter.Internal + +spec :: Spec +spec = do + describe "SourceLocation" $ it "Initialize SourceLocation" $ do + let sl = SourceLocation 0 0 + sl `shouldBe` SourceLocation 0 0 + describe "SourceRange" $ it "Initialize SourceRange" $ do + let sr = SourceRange (SourceLocation 0 0) (SourceLocation 0 5) + sr `shouldBe` SourceRange (SourceLocation 0 0) (SourceLocation 0 5) + describe "RChar" $ do + it "Initialize RChar" $ do + let rch = RChar (Just 'a') False (SourceLocation 0 0) "" + rch `shouldBe` RChar (Just 'a') False (SourceLocation 0 0) "" + it "Convert line to [RChar]" $ do + let line = "Line" + rcharl = toRCharList line + rcharl + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + it "Convert multiline string to [RChar]" $ do + let multiLine = "fi\nl\nes" + rcharl = toRCharList multiLine + rcharl + `shouldBe` [ RChar (Just 'f') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just '\n') False (SourceLocation 0 2) "" + , RChar (Just 'l') False (SourceLocation 1 0) "" + , RChar (Just '\n') False (SourceLocation 1 1) "" + , RChar (Just 'e') False (SourceLocation 2 0) "" + , RChar (Just 's') False (SourceLocation 2 1) "" + , RChar Nothing False (SourceLocation 2 2) "" + ] + it "Mark range in line (in the middle)" $ do + let line = toRCharList "Long Line" + range = SourceRange (SourceLocation 0 1) (SourceLocation 0 5) + rcharl = markRChars line range + rcharl + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'o') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'g') True (SourceLocation 0 3) "" + , RChar (Just ' ') True (SourceLocation 0 4) "" + , RChar (Just 'L') False (SourceLocation 0 5) "" + , RChar (Just 'i') False (SourceLocation 0 6) "" + , RChar (Just 'n') False (SourceLocation 0 7) "" + , RChar (Just 'e') False (SourceLocation 0 8) "" + , RChar Nothing False (SourceLocation 0 9) "" + ] + it "Mark range in line (the whole line)" $ do + let line = toRCharList "Long Line" + range = SourceRange (SourceLocation 0 0) (SourceLocation 0 9) + rcharl = markRChars line range + rcharl + `shouldBe` [ RChar (Just 'L') True (SourceLocation 0 0) "" + , RChar (Just 'o') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'g') True (SourceLocation 0 3) "" + , RChar (Just ' ') True (SourceLocation 0 4) "" + , RChar (Just 'L') True (SourceLocation 0 5) "" + , RChar (Just 'i') True (SourceLocation 0 6) "" + , RChar (Just 'n') True (SourceLocation 0 7) "" + , RChar (Just 'e') True (SourceLocation 0 8) "" + , RChar Nothing False (SourceLocation 0 9) "" + ] + it "Mark range in multiline string (in the middle)" $ do + let line = toRCharList "Li\nn\nes12" + range = SourceRange (SourceLocation 0 1) (SourceLocation 2 2) + rcharl = markRChars line range + rcharl + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just '\n') True (SourceLocation 0 2) "" + , RChar (Just 'n') True (SourceLocation 1 0) "" + , RChar (Just '\n') True (SourceLocation 1 1) "" + , RChar (Just 'e') True (SourceLocation 2 0) "" + , RChar (Just 's') True (SourceLocation 2 1) "" + , RChar (Just '1') False (SourceLocation 2 2) "" + , RChar (Just '2') False (SourceLocation 2 3) "" + , RChar Nothing False (SourceLocation 2 4) "" + ] + it "Mark range in multiline string (the whole multiline)" $ do + let multiline = toRCharList "Li\nn\nes12" + range = SourceRange (SourceLocation 0 0) (SourceLocation 2 4) + rcharl = markRChars multiline range + rcharl + `shouldBe` [ RChar (Just 'L') True (SourceLocation 0 0) "" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just '\n') True (SourceLocation 0 2) "" + , RChar (Just 'n') True (SourceLocation 1 0) "" + , RChar (Just '\n') True (SourceLocation 1 1) "" + , RChar (Just 'e') True (SourceLocation 2 0) "" + , RChar (Just 's') True (SourceLocation 2 1) "" + , RChar (Just '1') True (SourceLocation 2 2) "" + , RChar (Just '2') True (SourceLocation 2 3) "" + , RChar Nothing False (SourceLocation 2 4) "" + ] + it "Set replacement string (SourceLocation)" $ do + let line = toRCharList "Line" + sl = SourceLocation 0 1 + repl = "repl" + rchars = setReplacementStringSL line sl repl False + rchars + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "repl" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + it "Set replacement string (SourceRange)" $ do + let line = toRCharList "Line" + range = SourceRange (SourceLocation 0 1) (SourceLocation 0 3) + repl = "repl" + rchars = setReplacementStringSR line range repl False + rchars + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "repl" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + it "Evaluate single line (empty replacement)" $ do + let rchars = + [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Line" + it "Evaluate single line (one-to-none replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "ine" + it "Evaluate single line (many-to-none replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'q') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "q" + it "Evaluate single line (many-to-none replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "e" + it "Evaluate single line (one-to-one replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "T" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Tine" + it "Evaluate single line (many-to-one replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "T" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Te" + it "Evaluate single line (one-to-many replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "Argent" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') False (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Argentine" + it "Evaluate single line (many-to-many replacement)" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "Pineappl" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'e') False (SourceLocation 0 3) "" + , RChar Nothing False (SourceLocation 0 4) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Pineapple" + it "Evaluate multiline" $ do + let rchars = + [ RChar (Just 'L') True (SourceLocation 0 0) "Formula" + , RChar (Just 'i') True (SourceLocation 0 1) "" + , RChar (Just '\n') True (SourceLocation 0 2) "" + , RChar (Just '\n') False (SourceLocation 0 3) "" + , RChar (Just '1') False (SourceLocation 0 4) "" + , RChar Nothing False (SourceLocation 0 5) "" + ] + result = evaluateRChars rchars + result `shouldBe` "Formula\n1" + describe "Chunk" $ do + it "Take next chunk (no replacements)" $ do + let line = toRCharList "a very long text" + chunk = nextChunk line + chunk `shouldBe` (line, []) + it "Take next chunk (replacement in the middle)" $ do + let line = + [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just 'n') True (SourceLocation 0 2) "repl" + , RChar (Just 'e') True (SourceLocation 0 3) "" + , RChar (Just 'O') True (SourceLocation 0 4) "" + , RChar (Just 'f') False (SourceLocation 0 5) "" + , RChar Nothing False (SourceLocation 0 6) "" + ] + chunk = nextChunk line + chunk `shouldBe` (take 2 line, drop 2 line) + it "Take next chunk (replacement in the begining)" $ do + let line = + [ RChar (Just 'D') True (SourceLocation 0 0) "repl" + , RChar (Just 'o') True (SourceLocation 0 1) "" + , RChar (Just 'g') False (SourceLocation 0 2) "" + , RChar Nothing False (SourceLocation 0 3) "" + ] + chunk = nextChunk line + chunk `shouldBe` (take 1 line, drop 1 line) + it "Take next chunk (deletion in the begining)" $ do + let line = + [ RChar (Just 'D') True (SourceLocation 0 0) "" + , RChar (Just 'o') True (SourceLocation 0 1) "" + , RChar (Just 'g') False (SourceLocation 0 2) "" + , RChar Nothing False (SourceLocation 0 3) "" + ] + chunk = nextChunk line + chunk `shouldBe` (take 1 line, drop 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) + it "Take all chunks (single chunk)" $ do + let line = toRCharList "A single chunk" + chunks = allChunks line + chunks `shouldBe` [line] + it "Take all chunks (chunks separated by a new line)" $ do + let multiline = toRCharList "Two \n chunks" + chunks = allChunks multiline + chunks `shouldBe` [take 5 multiline, drop 5 multiline] + it "Take all chunks (chunks separated by a new line and deletion marks)" + $ do + let multiline = + [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just '\n') False (SourceLocation 0 2) "" + , RChar (Just 'e') True (SourceLocation 1 0) "repl" + , RChar (Just 't') True (SourceLocation 1 1) "" + , RChar (Just 'f') False (SourceLocation 2 0) "" + , RChar Nothing False (SourceLocation 2 1) "" + ] + chunks = allChunks multiline + chunks + `shouldBe` [ [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') False (SourceLocation 0 1) "" + , RChar (Just '\n') False (SourceLocation 0 2) "" + ] + , [RChar (Just 'e') True (SourceLocation 1 0) "repl"] + , [RChar (Just 't') True (SourceLocation 1 1) ""] + , [ RChar (Just 'f') False (SourceLocation 2 0) "" + , RChar Nothing False (SourceLocation 2 1) "" + ] + ] + it "Evaluate chunks (no replacements; short single line)" $ do + let chunks = allChunks $ toRCharList "Line" + str = evaluateChunks chunks + str `shouldBe` "Line" + it "Evaluate chunks (no replacements; short multiline)" $ do + let chunks = allChunks $ toRCharList "Multi\nline" + str = evaluateChunks chunks + str `shouldBe` "Multi\nline" + it "Evaluate chunks (no replacements; long single line)" $ do + let rchars = toRCharList $ BC.replicate 90 'a' + chunks = allChunks rchars + str = evaluateChunks chunks + str `shouldBe` BC.replicate 90 'a' + it "Evaluate chunks (no replacements; long multiline)" $ do + let ostr = + BC.replicate 20 'a' + <> "\n" + <> BC.replicate 40 'b' + <> "\n" + <> BC.replicate 90 'c' + <> "\n" + <> BC.replicate 70 'd' + rchars = toRCharList ostr + chunks = allChunks rchars + str = evaluateChunks chunks + str `shouldBe` ostr + it "Evaluate chunks (empty replacement; short line)" $ do + let range = SourceRange (SourceLocation 0 5) (SourceLocation 0 5) + repl = Replacement range "" + rchars = setReplacement (toRCharList "A short one") repl + chunks = allChunks rchars + str = evaluateChunks chunks + str `shouldBe` "A short one" + it "Evaluate chunks (short replacement; short line)" $ do + let range = SourceRange (SourceLocation 0 5) (SourceLocation 0 7) + repl = Replacement range "repl" + rchars = setReplacement (toRCharList "A short line") repl + chunks = allChunks rchars + str = evaluateChunks chunks + str `shouldBe` "A shorepl line" + it "Evaluate chunks (long replacement; short line)" $ do + let + range = SourceRange (SourceLocation 0 34) (SourceLocation 0 35) + replS = replicate 60 'a' + repl = Replacement range replS + rchars = setReplacement + (toRCharList "A very long line with many words in it") + repl + chunks = allChunks rchars + str = evaluateChunks chunks + str + `shouldBe` "A very long line with many words i" + <> "\n +" + <> BC.replicate 60 'a' + <> " it" + it "Evaluate chunks (long replacement; long line)" $ do + let range = SourceRange (SourceLocation 0 3) (SourceLocation 0 4) + replS = replicate 70 'a' + repl = Replacement range replS + rchars = setReplacement (toRCharList $ BC.replicate 70 'b') repl + chunks = allChunks rchars + str = evaluateChunks chunks + str + `shouldBe` BC.replicate 3 'b' + <> "\n +" + <> BC.replicate 70 'a' + <> "\n +" + <> BC.replicate 66 'b' + it "Evaluate chunks (multiline replacement; short line)" $ do + let range = SourceRange (SourceLocation 0 9) (SourceLocation 0 10) + replS = replicate 30 'a' <> "\n" <> replicate 30 'b' + repl = Replacement range replS + rchars = setReplacement (toRCharList $ BC.replicate 20 'c') repl + chunks = allChunks rchars + str = evaluateChunks chunks + str + `shouldBe` BC.replicate 9 'c' + <> BC.replicate 30 'a' + <> "\n" + <> BC.replicate 30 'b' + <> BC.replicate 10 'c' + it "Evaluate chunks (multiline replacement; long line)" $ do + let range = SourceRange (SourceLocation 0 8) (SourceLocation 0 9) + replS = replicate 30 'a' <> "\n" <> replicate 30 'b' + repl = Replacement range replS + rchars = setReplacement (toRCharList $ BC.replicate 60 'c') repl + chunks = allChunks rchars + str = evaluateChunks chunks + str + `shouldBe` BC.replicate 8 'c' + <> BC.replicate 30 'a' + <> "\n" + <> BC.replicate 30 'b' + <> "\n +" + <> BC.replicate 51 'c' + it "Evaluate chunks (multiline replacement; multiline)" $ do + let range = SourceRange (SourceLocation 0 10) (SourceLocation 0 15) + replS = replicate 30 'a' <> "\n" <> replicate 30 'd' + repl = Replacement range replS + rchars = setReplacement + (toRCharList $ BC.replicate 30 'c' <> "\n" <> BC.replicate 30 'c') + repl + chunks = allChunks rchars + str = evaluateChunks chunks + str + `shouldBe` BC.replicate 10 'c' + <> BC.replicate 30 'a' + <> "\n" + <> BC.replicate 30 'd' + <> BC.replicate 15 'c' + <> "\n" + <> BC.replicate 30 'c' + describe "Replacement" $ do + it "Initialize Replacement" $ do + let + r = + Replacement (SourceRange (SourceLocation 0 0) (SourceLocation 0 5)) "" + r `shouldBe` Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 0 5)) + "" + it "Set replacement (regular)" $ do + let line = toRCharList "LineOf" + range = SourceRange (SourceLocation 0 1) (SourceLocation 0 5) + replS = "repl" + r = Replacement range replS + res = setReplacement line r + res + `shouldBe` [ RChar (Just 'L') False (SourceLocation 0 0) "" + , RChar (Just 'i') True (SourceLocation 0 1) "repl" + , RChar (Just 'n') True (SourceLocation 0 2) "" + , RChar (Just 'e') True (SourceLocation 0 3) "" + , RChar (Just 'O') True (SourceLocation 0 4) "" + , RChar (Just 'f') False (SourceLocation 0 5) "" + , RChar Nothing False (SourceLocation 0 6) "" + ] + it "Set replacement (insertion in the middle)" $ do + let line = toRCharList "shorty" + range = SourceRange (SourceLocation 0 1) (SourceLocation 0 1) + replS = "Va" + r = Replacement range replS + res = setReplacement line r + res + `shouldBe` [ RChar (Just 's') False (SourceLocation 0 0) "" + , RChar (Just 'h') True (SourceLocation 0 1) "Vah" + , RChar (Just 'o') False (SourceLocation 0 2) "" + , RChar (Just 'r') False (SourceLocation 0 3) "" + , RChar (Just 't') False (SourceLocation 0 4) "" + , RChar (Just 'y') False (SourceLocation 0 5) "" + , RChar Nothing False (SourceLocation 0 6) "" + ] + it "Set replacement (insertion at the end)" $ do + let line = toRCharList "shorty" + range = SourceRange (SourceLocation 0 6) (SourceLocation 0 6) + replS = "Vb" + r = Replacement range replS + res = setReplacement line r + res + `shouldBe` [ RChar (Just 's') False (SourceLocation 0 0) "" + , RChar (Just 'h') False (SourceLocation 0 1) "" + , RChar (Just 'o') False (SourceLocation 0 2) "" + , RChar (Just 'r') False (SourceLocation 0 3) "" + , RChar (Just 't') False (SourceLocation 0 4) "" + , RChar (Just 'y') False (SourceLocation 0 5) "" + , RChar Nothing True (SourceLocation 0 6) "Vb" + ] + it "Set replacements" $ do + let code = toRCharList $ BC.replicate 6 'a' + range1 = SourceRange (SourceLocation 0 1) (SourceLocation 0 3) + range2 = SourceRange (SourceLocation 0 3) (SourceLocation 0 5) + replS1 = "repl1" + replS2 = "repl2" + r1 = Replacement range1 replS1 + r2 = Replacement range2 replS2 + res = setReplacements code [r1, r2] + res + `shouldBe` [ RChar (Just 'a') False (SourceLocation 0 0) "" + , RChar (Just 'a') True (SourceLocation 0 1) (BC.pack replS1) + , RChar (Just 'a') True (SourceLocation 0 2) "" + , RChar (Just 'a') True (SourceLocation 0 3) (BC.pack replS2) + , RChar (Just 'a') True (SourceLocation 0 4) "" + , RChar (Just 'a') False (SourceLocation 0 5) "" + , RChar Nothing False (SourceLocation 0 6) "" + ] + it "Disjoint replacements (disjoint, different lines)" $ do + let range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 14) + range2 = SourceRange (SourceLocation 1 2) (SourceLocation 1 20) + r1 = Replacement range1 "zz" + r2 = Replacement range2 "xx" + areDisjoint r1 r2 `shouldBe` True + areDisjoint r2 r1 `shouldBe` True + it "Disjoint replacements (disjoint, same line)" $ do + let range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) + range2 = SourceRange (SourceLocation 0 4) (SourceLocation 0 6) + r1 = Replacement range1 "ee" + r2 = Replacement range2 "ff" + areDisjoint r1 r2 `shouldBe` True + areDisjoint r2 r1 `shouldBe` True + it "Disjoint replacements (overlapping, same line)" $ do + let range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 14) + range2 = SourceRange (SourceLocation 0 7) (SourceLocation 0 20) + r1 = Replacement range1 "aa" + r2 = Replacement range2 "bb" + areDisjoint r1 r2 `shouldBe` False + areDisjoint r2 r1 `shouldBe` False + it "Disjoint replacements (overlapping, across lines)" $ do + let range1 = SourceRange (SourceLocation 0 2) (SourceLocation 2 14) + range2 = SourceRange (SourceLocation 1 7) (SourceLocation 5 20) + r1 = Replacement range1 "cc" + r2 = Replacement range2 "dd" + areDisjoint r1 r2 `shouldBe` False + areDisjoint r2 r1 `shouldBe` False + it "Apply replacement (continuation line)" $ do + let source = BC.replicate 30 'a' <> "\n" <> BC.replicate 30 'a' + range = SourceRange (SourceLocation 0 2) (SourceLocation 1 2) + replS = replicate 71 'b' <> "\n" <> replicate 71 'c' + r = Replacement range replS + res = applyReplacements source [r] + res + `shouldBe` ( BC.replicate 2 'a' + <> "\n +" + <> BC.pack replS + <> "\n +" + <> BC.replicate 28 'a' + ) + it "Apply replacement (insertion in the middle)" $ do + let source = "abc" + range = SourceRange (SourceLocation 0 0) (SourceLocation 0 0) + replS = "DDD" + r = Replacement range replS + res = applyReplacements source [r] + res `shouldBe` "DDDabc" + it "Apply replacement (insertion at the end)" $ do + let source = "abz" + range = SourceRange (SourceLocation 0 3) (SourceLocation 0 3) + replS = "DFG" + r = Replacement range replS + res = applyReplacements source [r] + res `shouldBe` "abzDFG" + it "Apply replacements (disjoint)" $ do + let source = BC.replicate 30 'a' + range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) + range2 = SourceRange (SourceLocation 0 4) (SourceLocation 0 6) + replS1 = "repl1" + replS2 = "2lper" + r1 = Replacement range1 replS1 + r2 = Replacement range2 replS2 + res = applyReplacements source [r1, r2] + res + `shouldBe` BC.replicate 2 'a' + <> BC.pack replS1 + <> BC.pack replS2 + <> BC.replicate 24 'a' + it "Apply replacements (overlapping)" $ do + let source = BC.replicate 30 'a' + range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) + range2 = SourceRange (SourceLocation 0 3) (SourceLocation 0 6) + replS = "repl" + r1 = Replacement range1 replS + r2 = Replacement range2 replS + evaluate (applyReplacements source [r1, r2]) + `shouldThrow` (== OverlappingError [(r1, r2)]) + it "Apply replacements (multiple overlapping)" $ do + let source = BC.replicate 30 'a' + range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) + range2 = SourceRange (SourceLocation 0 3) (SourceLocation 0 6) + range3 = SourceRange (SourceLocation 0 5) (SourceLocation 0 7) + replS = "repl" + r1 = Replacement range1 replS + r2 = Replacement range2 replS + r3 = Replacement range3 replS + evaluate (applyReplacements source [r1, r2, r3]) + `shouldThrow` (== OverlappingError [(r1, r2), (r2, r3)]) + it "Apply replacements (overlapping and out-of-order)" $ do + let source = BC.replicate 30 'a' + range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4) + range2 = SourceRange (SourceLocation 0 3) (SourceLocation 0 6) + range3 = SourceRange (SourceLocation 0 5) (SourceLocation 0 7) + replS = "repl" + r1 = Replacement range1 replS + r2 = Replacement range2 replS + r3 = Replacement range3 replS + evaluate (applyReplacements source [r3, r2, r1]) + `shouldThrow` (== OverlappingError [(r1, r2), (r2, r3)]) + it "Apply replacements (invalid ranges; out of code)" $ do + let source = BC.replicate 30 'a' + range = SourceRange (SourceLocation 0 2) (SourceLocation 0 31) + repl = Replacement range "" + evaluate (applyReplacements source [repl]) + `shouldThrow` (== InvalidRangeError) + it "Apply replacements (invalid ranges; invalid ordering of the parameters)" + $ do + let source = BC.replicate 30 'a' + range = SourceRange (SourceLocation 0 20) (SourceLocation 0 5) + repl = Replacement range "" + evaluate (applyReplacements source [repl]) + `shouldThrow` (== InvalidRangeError) diff --git a/test/Language/Fortran/RewriterSpec.hs b/test/Language/Fortran/RewriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/RewriterSpec.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fortran.RewriterSpec + ( spec + ) +where + +import Test.Hspec +import Control.Exception.Base ( try + , throw + ) +import Control.Monad ( foldM + , unless + ) +import qualified Data.Map as M +import System.Directory ( copyFile + , createDirectory + , getCurrentDirectory + , doesDirectoryExist + ) +import Language.Fortran.Rewriter +import qualified Data.ByteString.Lazy.Char8 as BC + +spec :: Spec +spec = do + describe "ReplacementMap" $ do + it "Initialize ReplacementMap" $ do + let + rm = M.fromList + [ ( "foo.f" :: String + , [ Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 1 1)) + "" + ] + ) + , ("bar.f", []) + ] + rm `shouldBe` M.fromList + [ ( "foo.f" + , [ Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 1 1)) + "" + ] + ) + , ("bar.f", []) + ] + it "Process ReplacementMap (empty; should not die)" $ do + let rm = M.empty + processReplacements rm + it "Process ReplacementMap (simple replacements)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 12) (SourceLocation 1 16)) + "cccc" + ] + ) + , ( workDir ++ "002_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 7) (SourceLocation 1 16)) + "" + ] + ) + , ( workDir ++ "003_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 12) (SourceLocation 1 17)) + "cccc1" + , Replacement + (SourceRange (SourceLocation 3 12) (SourceLocation 3 17)) + "cccc2" + ] + ) + , ( workDir ++ "004_unicode.f" + , [ Replacement + (SourceRange (SourceLocation 3 17) (SourceLocation 3 28)) + "int(z'deadbeef')" + ] + ) + , ( workDir ++ "005_unicode.f" + , [ Replacement + (SourceRange (SourceLocation 3 21) (SourceLocation 3 21)) + "" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper + body + base + Nothing + "replacementsmap-simple" + [ "001_foo.f" + , "002_foo.f" + , "003_foo.f" + , "004_unicode.f" + , "005_unicode.f" + ] + it "Process ReplacementMap (insertions)" $ do + base <- getCurrentDirectory + let body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 0 24) (SourceLocation 0 24)) + "\n call bbbb" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper body + base + Nothing + "replacementsmap-insertion" + ["001_foo.f"] + it "Process ReplacementMap (overlapping)" $ do + base <- getCurrentDirectory + let + r1 = Replacement + (SourceRange (SourceLocation 1 12) (SourceLocation 1 16)) + "cccc" + r2 = Replacement + (SourceRange (SourceLocation 1 7) (SourceLocation 1 16)) + "call dddd" + body workDir = + processReplacements $ M.fromList [(workDir ++ "001_foo.f", [r1, r2])] + wrapReplacementsMapInvocationTestHelper + body + base + (Just $ OverlappingError [(r2, r1)]) + "replacementsmap-overlapping" + ["001_foo.f"] + it "Process ReplacementMap (overlapping filtered)" $ do + base <- getCurrentDirectory + let r1 = Replacement + (SourceRange (SourceLocation 1 12) (SourceLocation 1 16)) + "cccc" + r2 = Replacement + (SourceRange (SourceLocation 1 7) (SourceLocation 1 16)) + "call dddd" + (repls, overlapping) = partitionOverlapping [r1, r2] + body workDir = + processReplacements $ M.fromList [(workDir ++ "001_foo.f", repls)] + repls `shouldBe` [r1] + wrapReplacementsMapInvocationTestHelper + body + base + Nothing + "replacementsmap-overlapping-filtered" + ["001_foo.f"] + overlapping `shouldBe` [r2] + it "Process ReplacementMap (invalid range; start line)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 9 12) (SourceLocation 9 15)) + "" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper body + base + (Just InvalidRangeError) + "replacementsmap-overlapping" + ["001_foo.f"] + it "Process ReplacementMap (invalid range; start column)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 112) (SourceLocation 1 115)) + "" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper body + base + (Just InvalidRangeError) + "replacementsmap-overlapping" + ["001_foo.f"] + it "Process ReplacementMap (invalid range; end line)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 13) (SourceLocation 19 115)) + "" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper body + base + (Just InvalidRangeError) + "replacementsmap-overlapping" + ["001_foo.f"] + it "Process ReplacementMap (invalid range; end column)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 1 13) (SourceLocation 1 115)) + "" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper body + base + (Just InvalidRangeError) + "replacementsmap-overlapping" + ["001_foo.f"] + it "Process ReplacementMap (column limit)" $ do + base <- getCurrentDirectory + let + body workDir = processReplacements $ M.fromList + [ ( workDir ++ "001_foo.f" + , [ Replacement + (SourceRange (SourceLocation 3 42) (SourceLocation 3 43)) + "999999999999999999999" + ] + ) + , ( workDir ++ "002_other.f" + , [ Replacement + (SourceRange (SourceLocation 4 61) (SourceLocation 4 62)) + "999999999999" + ] + ) + , ( workDir ++ "003_multiline.f" + , [ Replacement + (SourceRange (SourceLocation 4 61) (SourceLocation 4 62)) + "9 .and. \n + 4 .lt. 4\n + .or. .true." + ] + ) + , ( workDir ++ "004_comment.f" + , [ Replacement + (SourceRange (SourceLocation 2 18) (SourceLocation 2 19)) + "foobar" + , Replacement + (SourceRange (SourceLocation 8 16) (SourceLocation 8 27)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + ] + ) + , ( workDir ++ "005_removals.f" + , [ Replacement + (SourceRange (SourceLocation 2 50) (SourceLocation 3 24)) + "" + , Replacement + (SourceRange (SourceLocation 8 55) (SourceLocation 9 22)) + "" + ] + ) + , ( workDir ++ "006_linewrap_heuristic.f" + , [ Replacement + (SourceRange (SourceLocation 3 19) (SourceLocation 3 23)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + , Replacement + (SourceRange (SourceLocation 4 23) (SourceLocation 4 27)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + , Replacement + (SourceRange (SourceLocation 5 28) (SourceLocation 5 32)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + , Replacement + (SourceRange (SourceLocation 6 28) (SourceLocation 6 32)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + , Replacement + (SourceRange (SourceLocation 7 19) (SourceLocation 7 23)) + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" + , Replacement + (SourceRange (SourceLocation 8 6) (SourceLocation 8 24)) + "call testcommons_logarray_settori_findex(logical_1_to_4(test), 1)" + , Replacement + (SourceRange (SourceLocation 11 12) (SourceLocation 11 28)) + "call testcommons_set_logical2var(logical_2_to_4(l2))" + , Replacement + (SourceRange (SourceLocation 12 12) (SourceLocation 12 12)) + "call testcommons_set_logical2var(logical_2_to_4(l2))" + , Replacement + (SourceRange (SourceLocation 13 12) (SourceLocation 13 13)) + "call testcommons_set_logical2var(logical_2_to_4(l2))" + ] + ) + ] + wrapReplacementsMapInvocationTestHelper + body + base + Nothing + "replacementsmap-columnlimit" + [ "001_foo.f" + , "002_other.f" + , "003_multiline.f" + , "004_comment.f" + , "005_removals.f" + , "006_linewrap_heuristic.f" + ] + + describe "Filtering overlapping replacements" $ do + it "Simple overlap" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 0 2)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "b" + (disjoint, overlapping) = partitionOverlapping [r1, r2] + disjoint `shouldBe` [r1] + overlapping `shouldBe` [r2] + it "Reversed order" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 0 2)) + "b" + (disjoint, overlapping) = partitionOverlapping [r1, r2] + disjoint `shouldBe` [r1] + overlapping `shouldBe` [r2] + it "Middle overlap" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 0 2)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "b" + r3 = Replacement + (SourceRange (SourceLocation 0 2) (SourceLocation 0 4)) + "c" + (disjoint, overlapping) = partitionOverlapping [r1, r2, r3] + disjoint `shouldBe` [r1, r3] + overlapping `shouldBe` [r2] + it "Middle overlap out of order" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 0) (SourceLocation 0 2)) + "b" + r3 = Replacement + (SourceRange (SourceLocation 0 2) (SourceLocation 0 4)) + "c" + (disjoint, overlapping) = partitionOverlapping [r1, r2, r3] + disjoint `shouldBe` [r1] + overlapping `shouldBe` [r2, r3] + it "Exact overlap" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "b" + (disjoint, overlapping) = partitionOverlapping [r1, r2] + disjoint `shouldBe` [r1] + overlapping `shouldBe` [r2] + it "Overlapping beginning" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 2)) + "b" + (disjoint, overlapping) = partitionOverlapping [r1, r2] + disjoint `shouldBe` [r1] + overlapping `shouldBe` [r2] + it "Some overlapping" $ do + let + r1 = Replacement + (SourceRange (SourceLocation 0 1) (SourceLocation 0 3)) + "a" + r2 = Replacement + (SourceRange (SourceLocation 0 5) (SourceLocation 0 7)) + "b" + r3 = Replacement + (SourceRange (SourceLocation 0 3) (SourceLocation 0 5)) + "b" + r4 = Replacement + (SourceRange (SourceLocation 0 6) (SourceLocation 0 8)) + "b" + (disjoint, overlapping) = partitionOverlapping [r1, r2, r3, r4] + disjoint `shouldBe` [r1, r2, r3] + overlapping `shouldBe` [r4] + + +wrapReplacementsMapInvocationTestHelper + :: (String -> IO ()) + -> FilePath + -> Maybe ReplacementError + -> String + -> [String] + -> Expectation +wrapReplacementsMapInvocationTestHelper invocation baseDir Nothing ctx files = + do + (inputContextDir, outputContextDir, invokeResult) <- + wrapReplacementsMapInvocationTestHelper_ invocation baseDir ctx files + case invokeResult of + Left e -> error $ "Test failed unexpectedly; should pass: " <> show e + Right _ -> do + let res = foldM + (\acc file -> do + let expected = inputContextDir ++ "/" ++ file ++ ".expected" + let output = outputContextDir ++ "/" ++ file + ok <- compareFile expected output + return (acc && ok) + ) + True + files + res `shouldReturn` True +wrapReplacementsMapInvocationTestHelper invocation baseDir (Just expExcp) ctx files + = do + (_, _, invokeResult) <- wrapReplacementsMapInvocationTestHelper_ + invocation + baseDir + ctx + files + case invokeResult of + Left ex -> throw ex `shouldThrow` (== expExcp) + Right _ -> error "Test passed unexpectedly; should fail" + +wrapReplacementsMapInvocationTestHelper_ + :: (String -> IO ()) + -> FilePath + -> String + -> [String] + -> IO (String, String, Either ReplacementError ()) +wrapReplacementsMapInvocationTestHelper_ invocation baseDir ctx files = do + let inputContextDir = baseDir ++ "/test/Language/Fortran/samples/rewriter/" ++ ctx + outputDir = baseDir ++ "/test/rewriter-test-output" + outputContextDir = outputDir ++ "/" ++ ctx + doesDirectoryExist outputDir + >>= (\x -> unless x $ createDirectory outputDir) + doesDirectoryExist outputContextDir + >>= (\x -> unless x $ createDirectory outputContextDir) + mapM_ + (\file -> copyFile (inputContextDir ++ "/" ++ file) + (outputContextDir ++ "/" ++ file) + ) + files + result <- + try (invocation $ outputContextDir ++ "/") :: IO + (Either ReplacementError ()) + return (inputContextDir, outputContextDir, result) + +-------------------------------------------------------------------------------- + +-- | Utility function to compare file content. +compareFile :: FilePath -> FilePath -> IO Bool +compareFile expected actual = do + c1 <- BC.readFile expected + c2 <- BC.readFile actual + compareByteString c1 c2 + +compareByteString :: BC.ByteString -> BC.ByteString -> IO Bool +compareByteString expected actual = if expected == actual + then return True + else do + BC.putStrLn ">>>>>>> EXPECTED" + BC.putStrLn expected + BC.putStrLn ">>>>>>> ACTUAL" + BC.putStrLn actual + return False diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -35,6 +35,9 @@ intGen :: Integer -> Expression () intGen i = ExpValue () u $ ValInteger $ show i +initGen :: [Expression ()] -> Expression () +initGen es = ExpInitialisation () u $ fromList () es + realGen :: (Fractional a, Show a) => a -> Expression () realGen i = ExpValue () u $ ValReal $ show i