nsc-parser: allow parsing an include tree from a hardcoded 'Program'

app/Main.hs

@@ -10,7 +10,7 @@
 
 module Main (main) where
 
-import Language.NStar.Syntax (parseFile)
+import Language.NStar.Syntax (Section(IncludeS), Program(Program), parseAST)
 import Language.NStar.Typechecker (typecheck)
 import Language.NStar.CodeGen (SupportedArch(..), compileToElf)
 -- ! Experimental; remove once tested
@@ -19,25 +19,27 @@ import Data.Elf as Elf (compile, Size(..), Endianness(..), writeFile)
 import Text.Diagnose (printDiagnostic, (<~<), prettyText)
 import System.IO (stderr)
 import Console.NStar.Flags
-import Control.Monad (forM_, when)
+import Control.Monad (when)
 import System.Exit (exitFailure, exitSuccess)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (runExceptT, liftEither)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath.Posix (joinPath)
 import Data.IORef
+import Data.Located
+import qualified Data.Text as Text
 
 main :: IO ()
 main = do
   flags <- extractFlags
   -- print flags
 
-  forM_ (files flags) (tryCompile flags)
+  tryCompile flags (files flags)
 
 ------------------------------------------------------------------------------------------------
 
-tryCompile :: Flags -> FilePath -> IO ()
-tryCompile flags file = do
+tryCompile :: Flags -> [FilePath] -> IO ()
+tryCompile flags files = do
   let withColor = diagnostic_color (configuration flags)
       dumpAST = dump_ast (debugging flags)
       dumpTypedAST = dump_tast (debugging flags)
@@ -50,8 +52,12 @@ tryCompile flags file = do
 
   allFiles <- newIORef []
 
+  let dummyPos = Position (0, 0) (0, 0) "<command-line>"
+      file = "command-line" :@ dummyPos
+      program = Program [IncludeS ((:@ dummyPos) . Text.pack <$> files) :@ dummyPos]
+
   result <- runExceptT do
-        (files, res) <- liftIO (parseFile file)
+        (files, res) <- liftIO (parseAST file program)
         liftIO $ writeIORef allFiles files
         ast <- liftEither res
 

lib/nsc-parser/src/Language/NStar/Syntax/File.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
 
-module Language.NStar.Syntax.File (parseFile) where
+module Language.NStar.Syntax.File (parseFile, parseAST) where
 
 import Language.NStar.Syntax.Lexer
 import qualified Language.NStar.Syntax.Parser as P
@@ -45,6 +45,21 @@ parseFile file = do
   files <- readIORef files
   pure (files, res)
 
+parseAST :: (?lexerFlags :: LexerFlags, ?parserFlags :: ParserFlags, ?includePath :: [FilePath])
+         => Located FilePath -> Program -> IO ([(FilePath, [String])], Either (Diagnostic [] String Char) Program)
+parseAST f prog = do
+  files <- newIORef []
+
+  includePath <- mapM canonicalizePath ?includePath
+  let includePath_ = head <$> groupBy equalFilePath includePath
+  includePath <- mapM makeRelativeToCurrentDirectory includePath_
+  let ?includePath = includePath
+
+  res <- runExceptT (processUnitAST G.empty files f prog)
+  files <- readIORef files
+  pure (files, res)
+
+
 parseUnit :: (?lexerFlags :: LexerFlags, ?parserFlags :: ParserFlags, ?includePath :: [FilePath])
           => G.AdjacencyMap (Located FilePath)
           -> IORef [(FilePath, [String])]
@@ -71,6 +86,15 @@ parseUnit includeGraph includeFiles path@(filePath :@ p) = do
   (ast, warns) <- liftEither $ P.parseFile filePath tokens
   liftIO $ printDiagnostic True stderr (warns <~< content)
 
+  processUnitAST includeGraph includeFiles path ast
+
+processUnitAST :: (?lexerFlags :: LexerFlags, ?parserFlags :: ParserFlags, ?includePath :: [FilePath])
+               => G.AdjacencyMap (Located FilePath)
+               -> IORef [(FilePath, [String])]
+               -> Located FilePath
+               -> Program
+               -> CompUnit Program
+processUnitAST includeGraph includeFiles path ast = do
   let Program sections = ast
   newSections <- mconcat <$> forM sections \ case
     IncludeS files :@ _ -> do

nsc-lib.cabal

@@ -38,7 +38,7 @@ library
   hs-source-dirs:
       src
   default-extensions: BlockArguments LambdaCase BinaryLiterals ImplicitParams OverloadedStrings
-  ghc-options: -Wall -Wextra
+  ghc-options: -Wall -Wextra -Wno-name-shadowing
   build-depends:
       base >=4.7 && <5
     , diagnose
@@ -58,7 +58,7 @@ executable nsc
   hs-source-dirs:
       app
   default-extensions: BlockArguments LambdaCase BinaryLiterals ImplicitParams OverloadedStrings
-  ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N -Wall -Wextra
+  ghc-options: -Wall -Wextra -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
     , bytestring
@@ -86,7 +86,7 @@ test-suite nsc-tests
   hs-source-dirs:
       test
   default-extensions: BlockArguments LambdaCase BinaryLiterals ImplicitParams OverloadedStrings
-  ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Wextra -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       Glob
     , base >=4.7 && <5

package.yaml

@@ -32,6 +32,7 @@ library:
 ghc-options:
 - -Wall
 - -Wextra
+- -Wno-name-shadowing
 
 when:
   - condition: flag(debug)
@@ -54,8 +55,6 @@ executables:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
-    - -Wall
-    - -Wextra
     dependencies:
     - nsc-lib
     - nsc-flags