fortran-src 0.4.0 → 0.4.2

raw patch · 26 files changed

+2016/−174 lines, 26 filesdep +temporarydep ~binarydep ~bytestringdep ~deepseqnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: temporary

Dependency ranges changed: binary, bytestring, deepseq, filepath

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• README.md +44/−0
• fortran-src.cabal +34/−21
• src/Language/Fortran/AST.hs +0/−1
• src/Language/Fortran/Analysis.hs +0/−1
• src/Language/Fortran/Analysis/BBlocks.hs +0/−1
• src/Language/Fortran/Analysis/DataFlow.hs +0/−1
• src/Language/Fortran/Analysis/ModGraph.hs +7/−19
• src/Language/Fortran/Analysis/Renaming.hs +1/−2
• src/Language/Fortran/Lexer/FixedForm.x +4/−1
• src/Language/Fortran/Parser/Any.hs +4/−21
• src/Language/Fortran/Parser/Fortran77.y +16/−16
• src/Language/Fortran/ParserMonad.hs +19/−38
• src/Language/Fortran/PrettyPrint.hs +79/−5
• src/Language/Fortran/Rewriter.hs +135/−0
• src/Language/Fortran/Rewriter/Internal.hs +353/−0
• src/Language/Fortran/Util/Files.hs +41/−0
• src/Language/Fortran/Util/Position.hs +0/−1
• src/Language/Fortran/Version.hs +74/−0
• src/Main.hs +21/−35
• test/Language/Fortran/Lexer/FixedFormSpec.hs +23/−0
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +36/−0
• test/Language/Fortran/PrettyPrintSpec.hs +47/−11
• test/Language/Fortran/Rewriter/InternalSpec.hs +592/−0
• test/Language/Fortran/RewriterSpec.hs +466/−0
• test/TestUtil.hs +3/−0

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

@@ -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...] <file>+      -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+```

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

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

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

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

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

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

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

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

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

@@ -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 (d</>f)   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

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

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

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

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

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

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

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

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

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

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

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

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

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

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