re-add F77 inlined includes parser

app/Main.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Main where

src/Language/Fortran/Parser.hs

@@ -13,15 +13,21 @@ combinators are exposed to assist in manually configuring parsers.
 module Language.Fortran.Parser
   (
   -- * Main parsers (ProgramFile, with transformation)
-    f66, f77, f90, f95, f2003
+    byVer, byVerWithMods
+  , f66, f77, f77e, f77l, f90, f95, f2003
 
   -- * Main parsers without post-parse transformation
-  , f66NoTransform, f77NoTransform, f90NoTransform, f95NoTransform, f2003NoTransform
+  , f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform
+    , f90NoTransform, f95NoTransform, f2003NoTransform
 
-  -- * Parser former combinators
+  -- * Various combinators
   , transformAs, defaultTransformation
   , StateInit, ParserMaker, makeParser, makeParserFixed, makeParserFree
   , initParseStateFixed, initParseStateFree
+
+  -- * F77 with inlined includes
+  -- $f77includes
+  , f77lIncludes
   ) where
 
 import Language.Fortran.AST
@@ -36,6 +42,7 @@ import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed
 import qualified Language.Fortran.Parser.Free.Lexer  as Free
 import Language.Fortran.Version
 import Language.Fortran.Util.Position
+import Language.Fortran.Util.ModFile
 import Language.Fortran.Transformation.Monad
 import qualified Language.Fortran.Transformation.Grouping                 as Trans
 import qualified Language.Fortran.Transformation.Disambiguation.Function  as Trans
@@ -44,24 +51,69 @@ import qualified Language.Fortran.Transformation.Disambiguation.Intrinsic as Tra
 import qualified Data.ByteString.Char8 as B
 import Data.Data
 
+import Control.Monad.State
+import qualified Data.Map as Map
+import           Data.Map ( Map )
+import Data.Generics.Uniplate.Operations ( descendBiM )
+import Control.Exception ( throwIO )
+import System.FilePath ( (</>) )
+import System.Directory ( doesFileExist )
+
 -- | Our common Fortran parser type takes a filename and input, and returns
 --   either a normalized error (tokens are printed) or an untransformed
 --   'ProgramFile'.
 type Parser a = String -> B.ByteString -> Either ParseErrorSimple a
 
 --------------------------------------------------------------------------------
 
-f66, f77, f90, f95, f2003 :: Parser (ProgramFile A0)
-f66   = transformAs Fortran66   f66NoTransform
-f77   = transformAs Fortran77   f77NoTransform
-f90   = transformAs Fortran90   f90NoTransform
-f95   = transformAs Fortran95   f95NoTransform
-f2003 = transformAs Fortran2003 f2003NoTransform
-
-f66NoTransform, f77NoTransform, f90NoTransform, f95NoTransform, f2003NoTransform
+byVer :: FortranVersion -> Parser (ProgramFile A0)
+byVer = \case
+  Fortran66   -> f66
+  Fortran77   -> f77
+  Fortran77Extended -> f77e
+  Fortran77Legacy   -> f77l
+  Fortran90   -> f90
+  Fortran95   -> f95
+  Fortran2003 -> f2003
+  v           -> error $ "Language.Fortran.Parser.byVer: no parser available for requested version: " <> show v
+
+byVerWithMods :: ModFiles -> FortranVersion -> Parser (ProgramFile A0)
+byVerWithMods mods = \case
+  Fortran66         -> f66Mods mods
+  Fortran77         -> f77Mods mods
+  Fortran77Extended -> f77eMods mods
+  Fortran77Legacy   -> f77lMods mods
+  Fortran90         -> f90Mods mods
+  Fortran95         -> f95Mods mods
+  Fortran2003       -> f2003Mods mods
+  v                 -> error $ "Language.Fortran.Parser.byVerWithMods: no parser available for requested version: " <> show v
+
+f66, f77, f77e, f77l, f90, f95, f2003 :: Parser (ProgramFile A0)
+f66   = f66Mods   []
+f77   = f77Mods   []
+f77e  = f77eMods  []
+f77l  = f77lMods  []
+f90   = f90Mods   []
+f95   = f95Mods   []
+f2003 = f2003Mods []
+
+f66Mods, f77Mods, f77eMods, f77lMods, f90Mods, f95Mods, f2003Mods
+    :: ModFiles -> Parser (ProgramFile A0)
+f66Mods   = transformAs Fortran66         f66NoTransform
+f77Mods   = transformAs Fortran77         f77NoTransform
+f77eMods  = transformAs Fortran77Extended f77NoTransform
+f77lMods  = transformAs Fortran77Legacy   f77NoTransform
+f90Mods   = transformAs Fortran90         f90NoTransform
+f95Mods   = transformAs Fortran95         f95NoTransform
+f2003Mods = transformAs Fortran2003       f2003NoTransform
+
+f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform,
+  f90NoTransform, f95NoTransform, f2003NoTransform
     :: Parser (ProgramFile A0)
 f66NoTransform   = makeParserFixed F66.programParser   Fortran66
 f77NoTransform   = makeParserFixed F77.programParser   Fortran77
+f77eNoTransform  = makeParserFixed F77.programParser   Fortran77Extended
+f77lNoTransform  = makeParserFixed F77.programParser   Fortran77Legacy
 f90NoTransform   = makeParserFree  F90.programParser   Fortran90
 f95NoTransform   = makeParserFree  F95.programParser   Fortran95
 f2003NoTransform = makeParserFree  F2003.programParser Fortran2003
@@ -70,9 +122,15 @@ f2003NoTransform = makeParserFree  F2003.programParser Fortran2003
 
 transformAs
     :: Data a
-    => FortranVersion -> Parser (ProgramFile a) -> Parser (ProgramFile a)
-transformAs fv p fn bs =
-    runTransform mempty mempty (defaultTransformation fv) <$> p fn bs
+    => FortranVersion -> Parser (ProgramFile a) -> ModFiles
+    -> Parser (ProgramFile a)
+transformAs fv p mods fn bs = do
+    pf <- p fn bs
+    let pf' = pfSetFilename fn pf
+    return $ transform pf'
+  where transform = runTransform (combinedTypeEnv mods)
+                                 (combinedModuleMap mods)
+                                 (defaultTransformation fv)
 
 -- | The default post-parse AST transformation for each Fortran version.
 --
@@ -130,3 +188,60 @@ initParseStatePartial = ParseState
   , psFilename = undefined
   , psParanthesesCount = ParanthesesCount 0 False
   , psContext = [ ConStart ] }
+
+--------------------------------------------------------------------------------
+
+{- $f77includes
+The Fortran 77 parser can parse and inline includes at parse time. Parse errors
+are thrown as IO exceptions.
+
+Can be cleaned up and generalized to use for other parsers.
+-}
+
+f77lIncludes
+    :: [FilePath] -> ModFiles -> String -> B.ByteString
+    -> IO (ProgramFile A0)
+f77lIncludes incs mods fn bs = do
+    case f77lNoTransform fn bs of
+      Left e -> liftIO $ throwIO e
+      Right pf -> do
+        let pf' = pfSetFilename fn pf
+        pf'' <- evalStateT (descendBiM (f77lIncludesInline incs []) pf') Map.empty
+        let pf''' = runTransform (combinedTypeEnv mods)
+                                 (combinedModuleMap mods)
+                                 (defaultTransformation Fortran77Legacy)
+                                 pf''
+        return pf'''
+
+f77lIncludesInner :: Parser [Block A0]
+f77lIncludesInner = makeParserFixed F77.includesParser Fortran77Legacy
+
+f77lIncludesInline
+    :: [FilePath] -> [FilePath] -> Statement A0
+    -> StateT (Map String [Block A0]) IO (Statement A0)
+f77lIncludesInline dirs seen st = case st of
+  StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do
+    if notElem path seen then do
+      incMap <- get
+      case Map.lookup path incMap of
+        Just blocks' -> pure $ StInclude a s e (Just blocks')
+        Nothing -> do
+          (fullPath, inc) <- liftIO $ readInDirs dirs path
+          case f77lIncludesInner fullPath inc of
+            Right blocks -> do
+              blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks
+              modify (Map.insert path blocks')
+              return $ StInclude a s e (Just blocks')
+            Left err -> liftIO $ throwIO err
+    else return st
+  _ -> return st
+
+readInDirs :: [String] -> String -> IO (String, B.ByteString)
+readInDirs [] f = fail $ "cannot find file: " ++ f
+readInDirs (d:ds) f = do
+  let path = d</>f
+  b <- doesFileExist path
+  if b then
+    (path,) <$> B.readFile path
+  else
+    readInDirs ds f

src/Language/Fortran/Parser/Common.hs

@@ -80,7 +80,8 @@ data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)
 data ParseErrorSimple = ParseErrorSimple
   { errorPos      :: Position
   , errorFilename :: String
-  , errorMsg      :: String }
+  , errorMsg      :: String
+  } deriving (Exception)
 
 fromParseResultUnsafe :: (Show c) => ParseResult b c a -> a
 fromParseResultUnsafe (ParseOk a _) = a