fixes issue #1196

ReleaseNotes.md

@@ -3,7 +3,8 @@
 ## Unreleased
 
 * [Issue #1194](https://github.com/AmpersandTarski/Ampersand/issues/1194) Ampersand will output the options in debug mode.
-* Allow multiple files to be declared as root files. The extra files will be handled as if they were INCLUDEd in the first one.
+* [Issue #1196](https://github.com/AmpersandTarski/Ampersand/issues/1196) Allow multiple files to be declared as 
+    root files. The extra files will be handled as if they were INCLUDEd in the first one.
 
 ## v4.2.0 ( 16 July 2021)
 

src/Ampersand/Daemon/Parser.hs

@@ -13,17 +13,17 @@ import           Ampersand.Input.ADL1.CtxError
 import qualified RIO.NonEmpty as NE
 import           Ampersand.FSpec.MetaModels
 import           Ampersand.Types.Config
-import           Ampersand.Misc.HasClasses (HasRootFile(..),rootFileL, HasDaemonOpts(..), showWarningsL)
+import           Ampersand.Misc.HasClasses (HasRootFile(..),rootFileL, HasDaemonOpts(..), showWarningsL,Roots(..))
 
 -- | parseProject will try to parse a file. If it succeeds, it will 
 --   also parse all INCLUDED files transitively. Any of these parses could
 --   fail. It will return a tuple containing the Loads and a list of 
 --   the filepaths that are read. 
 parseProject :: (HasDaemonOpts env, HasRunner env) => 
                 FilePath ->  RIO env ([Load],[FilePath])
-parseProject rootAdl =  local (set rootFileL (Just rootAdl)) $ do
+parseProject rootAdl =  local (set rootFileL (Roots [rootAdl])) $ do
     showWarnings <- view showWarningsL
-    (pc,gPctx) <- parseFileTransitive rootAdl 
+    (pc,gPctx) <- parseFilesTransitive (Roots [rootAdl]) 
     env <- ask
     let loadedFiles = map pcCanonical pc
         gActx = pCtx2Fspec env =<< gPctx

src/Ampersand/FSpec/ToFSpec/CreateFspec.hs

@@ -60,8 +60,8 @@ createFspec =
  do env <- ask
     let recipe = view recipeL env
     userScript <- do
-         rootFile <- fromMaybe (fatal "No script was given!") <$> view rootFileL
-         snd <$> parseFileTransitive rootFile -- the P_Context of the user's sourceFile
+         rootFiles <- view rootFileL
+         snd <$> parseFilesTransitive rootFiles -- the P_Context of the user's sourceFile
     formalAmpersandScript  <- parseFormalAmpersand
     prototypeContextScript <- parsePrototypeContext
     let pContext

src/Ampersand/Input/Parsing.hs

@@ -5,7 +5,7 @@
 -- return an FSpec, as tuned by the command line options.
 -- This might include that RAP is included in the returned FSpec.
 module Ampersand.Input.Parsing (
-      parseFileTransitive
+      parseFilesTransitive
     , parseFormalAmpersand
     , parsePrototypeContext
     , parseRule
@@ -16,40 +16,6 @@ module Ampersand.Input.Parsing (
 import Ampersand.ADL1
     ( Origin(Origin), mergeContexts, P_Context, Term, TermPrim )
 import Ampersand.Basics
-    ( snd,
-      otherwise,
-      map,
-      ($),
-      Eq((==)),
-      Monad((>>=), return),
-      Applicative(pure),
-      Foldable(elem, foldr),
-      Traversable(mapM, sequence),
-      Semigroup((<>)),
-      Bool(False),
-      Maybe(..),
-      Either(Left, Right),
-      tshow,
-      (.),
-      Text,
-      fatal,
-      FilePath,
-      SomeException,
-      (<$>),
-      isJust,
-      reverse,
-      (&&),
-      (||),
-      decodeUtf8,
-      readFileUtf8,
-      writeFileUtf8,
-      logDebug,
-      logInfo,
-      catch,
-      MonadIO(liftIO),
-      Display(display),
-      HasLogFunc,
-      RIO )
 import Ampersand.Core.ShowPStruct ( showP )
 import Ampersand.Input.ADL1.CtxError
     ( addWarnings,
@@ -66,7 +32,7 @@ import Ampersand.Input.Archi.ArchiAnalyze ( archi2PContext )
 import Ampersand.Input.PreProcessor
     ( preProcess, processFlags, PreProcDefine )
 import Ampersand.Input.Xslx.XLSX ( parseXlsxFile )
-import Ampersand.Misc.HasClasses ( HasFSpecGenOpts )
+import Ampersand.Misc.HasClasses ( HasFSpecGenOpts,Roots(..) )
 import Ampersand.Prototype.StaticFiles_Generated
     ( getStaticFileContent,
       FileKind(PrototypeContext, FormalAmpersand) )
@@ -89,17 +55,20 @@ import System.FilePath
       takeExtension )
 import           Text.Parsec.Prim (runP)
 
-
-
--- | Parse an Ampersand file and all transitive includes
-parseFileTransitive :: (HasFSpecGenOpts env, HasLogFunc env) =>
-            FilePath   -- ^ The path of the file to be parsed, either absolute or relative to the current user's path
+-- | Parse Ampersand files and all transitive includes
+parseFilesTransitive :: (HasFSpecGenOpts env, HasLogFunc env) =>
+            Roots
          -> RIO env ([ParseCandidate], Guarded P_Context) -- ^ A tuple containing a list of parsed files and the The resulting context
-parseFileTransitive fp = do 
+parseFilesTransitive xs = do -- parseFileTransitive . NE.head . getRoots --TODO Fix this, to also take the tail files into account. 
     curDir <- liftIO getCurrentDirectory
-    canonical <- liftIO $ canonicalizePath fp
-    parseThing' ParseCandidate
-       { pcBasePath  = Just curDir
+    canonical <- liftIO . mapM canonicalizePath . getRoots $ xs
+    let candidates = map (mkCandidate curDir) canonical 
+
+    parseThings candidates
+  where
+    mkCandidate :: FilePath -> FilePath -> ParseCandidate
+    mkCandidate curdir canonical = ParseCandidate
+       { pcBasePath  = Just curdir
        , pcOrigin    = Nothing
        , pcFileKind  = Nothing
        , pcCanonical = canonical
@@ -125,14 +94,14 @@ parsePrototypeContext = parseThing ParseCandidate
 
 parseThing :: (HasFSpecGenOpts env, HasLogFunc env) =>
               ParseCandidate -> RIO env (Guarded P_Context)
-parseThing pc = snd <$> parseThing' pc 
+parseThing pc = snd <$> parseThings [pc] 
 
-parseThing' :: (HasFSpecGenOpts env, HasLogFunc env) =>
-               ParseCandidate -> RIO env ([ParseCandidate], Guarded P_Context) 
-parseThing' pc = do
-  results <- parseADLs [] [pc]
+parseThings :: (HasFSpecGenOpts env, HasLogFunc env) =>
+               [ParseCandidate] -> RIO env ([ParseCandidate], Guarded P_Context) 
+parseThings pcs = do
+  results <- parseADLs [] pcs
   case results of 
-     Errors err    -> return ([pc], Errors err)
+     Errors err    -> return (pcs, Errors err)
      Checked xs ws -> return ( candidates
                              , Checked mergedContexts ws
                              )

src/Ampersand/Misc/HasClasses.hs

@@ -93,20 +93,18 @@ class HasGenerateMetamodel a where
 instance HasGenerateMetamodel ProtoOpts where
   generateMetamodelL = lens xgenerateMetamodel (\x y -> x { xgenerateMetamodel = y })
 
+newtype Roots = Roots {getRoots :: [FilePath]}
+instance Show Roots where
+  show = L.intercalate ", " . getRoots
 class HasRootFile a where
-  rootFileL :: Lens' a (Maybe FilePath)
+  rootFileL :: Lens' a Roots
   baseName :: a -> FilePath
-  baseName  =
-    maybe
-      (fatal "Cannot determine the basename of the script that is being compiled")
-      takeBaseName
-    . view rootFileL
+  baseName x = case getRoots . view rootFileL $ x of
+    [] ->  fatal "Cannot determine the basename of the script that is being compiled"
+    (h:_) -> takeBaseName h
   dirSource :: a -> FilePath -- the directory of the script that is being compiled
-  dirSource =
-    maybe
-      (fatal "Cannot determine the directory of the script that is being compiled")
-      takeDirectory
-    . view rootFileL
+  dirSource = takeDirectory . baseName
+
 instance HasFSpecGenOpts a => HasRootFile a where
   rootFileL = fSpecGenOptsL . lens xrootFile (\x y -> x { xrootFile = y })
 
@@ -229,7 +227,7 @@ data Recipe =
     deriving (Show, Enum, Bounded)
 
 data FSpecGenOpts = FSpecGenOpts
-  { xrootFile :: !(Maybe FilePath)  --relative path. Must be set the first time it is read.
+  { xrootFile :: !Roots  --relative paths. Must be set the first time it is read.
   , xsqlBinTables :: !Bool
   , xgenInterfaces :: !Bool -- 
   , xnamespace :: !Text -- prefix database identifiers with this namespace, to isolate namespaces within the same database.
@@ -242,7 +240,7 @@ data FSpecGenOpts = FSpecGenOpts
 } deriving Show
 instance HasOptions FSpecGenOpts where
   optsList opts =
-     [ ("AMPERSAND_SCRIPT", maybe "" T.pack $ xrootFile opts)
+     [ ("AMPERSAND_SCRIPT", tshow $ xrootFile opts)
      , ("--sql-bin-tables", tshow $ xsqlBinTables opts)
      , ("--interfaces", tshow $ xgenInterfaces opts)
      , ("--namespace", tshow $ xnamespace opts)

src/Ampersand/Options/FSpecGenOptsParser.hs

@@ -3,7 +3,7 @@
 module Ampersand.Options.FSpecGenOptsParser (fSpecGenOptsParser, defFSpecGenOpts) where
 
 import Ampersand.Basics
-import Ampersand.Misc.HasClasses (FSpecGenOpts (..), Recipe (..))
+import Ampersand.Misc.HasClasses (FSpecGenOpts (..), Recipe (..), Roots (Roots))
 -- import           Ampersand.FSpec.ShowMeatGrinder (MetaModel(..))
 import Options.Applicative
 import Options.Applicative.Builder.Extra
@@ -16,10 +16,7 @@ fSpecGenOptsParser ::
   Parser FSpecGenOpts
 fSpecGenOptsParser isForDaemon =
   FSpecGenOpts
-    <$> ( if isForDaemon
-            then pure Nothing -- The rootfile should come from the daemon config file.
-            else Just <$> rootFileP
-        )
+    <$> rootsP
     <*> sqlBinTablesP
     <*> genInterfacesP
     <*> namespaceP
@@ -28,6 +25,10 @@ fSpecGenOptsParser isForDaemon =
     <*> knownRecipeP
     <*> allowInvariantViolationsP
   where
+    rootsP :: Parser Roots
+    rootsP = if isForDaemon
+            then pure $ Roots [] -- The rootfile should come from the daemon config file.
+            else Roots <$> some rootFileP
 
     rootFileP :: Parser FilePath
     rootFileP =
@@ -152,10 +153,10 @@ fSpecGenOptsParser isForDaemon =
               )
         )
 
-defFSpecGenOpts :: FilePath -> FSpecGenOpts
+defFSpecGenOpts :: [FilePath] -> FSpecGenOpts
 defFSpecGenOpts rootAdl =
   FSpecGenOpts
-    { xrootFile = Just rootAdl,
+    { xrootFile = Roots rootAdl,
       xsqlBinTables = False,
       xgenInterfaces = False,
       xnamespace = "",

src/Ampersand/Test/Parser/ParserTest.hs

@@ -9,6 +9,7 @@ module Ampersand.Test.Parser.ParserTest (
 import           Ampersand.Basics
 import           Ampersand.Input.ADL1.CtxError (Guarded(..),CtxError)
 import           Ampersand.Input.Parsing
+import           Ampersand.Misc.HasClasses
 import           Ampersand.Options.FSpecGenOptsParser
 import           Ampersand.Types.Config
 import qualified RIO.NonEmpty as NE
@@ -19,16 +20,16 @@ parseScripts :: (HasRunner env) =>
 parseScripts paths =
   case paths of
     [] -> return True
-    (f:fs) -> do
-        let fSpecGenOpts = defFSpecGenOpts f
-        parsed <- snd <$> extendWith fSpecGenOpts (parseFileTransitive f)
+    h:tl -> do
+        let fSpecGenOpts = defFSpecGenOpts (h:tl)
+        parsed <- snd <$> extendWith fSpecGenOpts (parseFilesTransitive (Roots (h:tl)))
         case parsed of
             Checked _ ws -> do
-                logInfo $ "Parsed: " <> display (T.pack f)
+                logInfo $ "Parsed: " <> display (T.pack h)
                 mapM_ logWarn (fmap displayShow ws)
-                parseScripts fs
+                parseScripts tl
             Errors  e -> do 
-                logError $ "Cannot parse: " <> display (T.pack f)
+                logError $ "Cannot parse: " <> display (T.pack h)
                 showErrors (NE.toList e)
                 return False