{- -----------------------------------------------------------------------------
Copyright 2020-2021,2023 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

module Cli.RunCompiler (
  TraceEntry(..),
  parseTracesFile,
  runCompiler,
) where

import Control.Monad (foldM,when)
import Data.List (intercalate,isSuffixOf,nub)
import System.Directory
import System.FilePath
import System.IO
import System.Posix.Temp (mkdtemp)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Base.CompilerError
import Base.TrackedErrors
import Cli.CompileOptions
import Cli.Compiler
import Cli.Programs
import Module.CompileMetadata
import Module.Paths
import Module.ProcessMetadata
import Parser.Common
import Parser.TextParser


runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> TrackedErrorsIO ()
runCompiler :: forall r b.
(PathIOHandler r, CompilerBackend b) =>
r -> b -> CompileOptions -> TrackedErrorsIO ()
runCompiler r
resolver b
backend (CompileOptions HelpMode
_ [String]
_ [String]
_ [String]
ds [ExtraSource]
_ [String]
_ String
p (ExecuteTests [String]
tp Maybe String
cl) ForceMode
f Int
_) = do
  String
base <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> m String
resolveBaseModule r
resolver
  [LoadedTests]
ts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (MetadataMap, [LoadedTests])
-> String -> TrackedErrorsT IO (MetadataMap, [LoadedTests])
preloadTests (forall k a. Map k a
Map.empty,[]) [String]
ds
  forall {m :: * -> *}. ErrorContextM m => [LoadedTests] -> m ()
checkTestFilters [LoadedTests]
ts
  String
cl2 <- forall {m :: * -> *}.
(MonadIO m, ErrorContextM m) =>
Maybe String -> m String
prepareCallLog Maybe String
cl
  [((Int, Int), TrackedErrors ())]
allResults <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall r b.
(PathIOHandler r, CompilerBackend b) =>
r
-> b
-> String
-> String
-> [String]
-> LoadedTests
-> TrackedErrorsT IO [((Int, Int), TrackedErrors ())]
runModuleTests r
resolver b
backend String
cl2 String
base [String]
tp) [LoadedTests]
ts
  let passed :: Int
passed = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Int, Int), TrackedErrors ())]
allResults
  let failed :: Int
failed = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Int, Int), TrackedErrors ())]
allResults
  forall {m :: * -> *} {a} {a}.
(Show a, Show a, MonadIO m) =>
a -> a -> TrackedErrors () -> TrackedErrorsT m ()
processResults Int
passed Int
failed (forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ forall a b. (a, b) -> b
snd [((Int, Int), TrackedErrors ())]
allResults) where
    prepareCallLog :: Maybe String -> m String
prepareCallLog (Just String
cl2) = do
      String
clFull <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String
p String -> String -> String
</> String
cl2)
      forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM forall a b. (a -> b) -> a -> b
$ String
"Logging calls to " forall a. [a] -> [a] -> [a]
++ String
clFull
      forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
clFull (forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [String]
tracesLogHeader) forall a. [a] -> [a] -> [a]
++ String
"\n")
      forall (m :: * -> *) a. Monad m => a -> m a
return String
clFull
    prepareCallLog Maybe String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    preloadTests :: (MetadataMap, [LoadedTests])
-> String -> TrackedErrorsT IO (MetadataMap, [LoadedTests])
preloadTests (MetadataMap
ca,[LoadedTests]
ms) String
d = do
      VersionHash
compilerHash <- forall b (m :: * -> *).
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> m VersionHash
getCompilerHash b
backend
      CompileMetadata
m <- VersionHash
-> ForceMode
-> MetadataMap
-> String
-> TrackedErrorsIO CompileMetadata
loadModuleMetadata VersionHash
compilerHash ForceMode
f MetadataMap
ca (String
p String -> String -> String
</> String
d)
      let ca2 :: MetadataMap
ca2 = MetadataMap
ca forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [CompileMetadata] -> MetadataMap
mapMetadata [CompileMetadata
m]
      ModuleConfig
rm <- String -> TrackedErrorsIO ModuleConfig
loadRecompile (String
p String -> String -> String
</> String
d)
      let ca3 :: MetadataMap
ca3 = MetadataMap
ca2 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [CompileMetadata] -> MetadataMap
mapMetadata []
      [CompileMetadata]
deps1 <- VersionHash
-> ForceMode
-> MetadataMap
-> CompileMetadata
-> TrackedErrorsIO [CompileMetadata]
loadTestingDeps VersionHash
compilerHash ForceMode
f MetadataMap
ca3 CompileMetadata
m
      let ca4 :: MetadataMap
ca4 = MetadataMap
ca3 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [CompileMetadata] -> MetadataMap
mapMetadata [CompileMetadata]
deps1
      [CompileMetadata]
deps2 <- VersionHash
-> ForceMode
-> MetadataMap
-> [CompileMetadata]
-> TrackedErrorsIO [CompileMetadata]
loadPrivateDeps VersionHash
compilerHash ForceMode
f MetadataMap
ca4 ([CompileMetadata
m]forall a. [a] -> [a] -> [a]
++[CompileMetadata]
deps1)
      let ca5 :: MetadataMap
ca5 = MetadataMap
ca4 forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` [CompileMetadata] -> MetadataMap
mapMetadata [CompileMetadata]
deps2
      ExprMap SourceContext
em <- String -> ModuleConfig -> TrackedErrorsIO (ExprMap SourceContext)
getExprMap (String
p String -> String -> String
</> String
d) ModuleConfig
rm
      forall (m :: * -> *) a. Monad m => a -> m a
return (MetadataMap
ca5,[LoadedTests]
ms forall a. [a] -> [a] -> [a]
++ [CompileMetadata
-> ExprMap SourceContext
-> [CompileMetadata]
-> [CompileMetadata]
-> LoadedTests
LoadedTests CompileMetadata
m ExprMap SourceContext
em ([CompileMetadata]
deps1) [CompileMetadata]
deps2])
    checkTestFilters :: [LoadedTests] -> m ()
checkTestFilters [LoadedTests]
ts = do
      let possibleTests :: [String]
possibleTests = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (CompileMetadata -> [String]
cmTestFiles forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoadedTests -> CompileMetadata
ltMetadata) [LoadedTests]
ts
      let remaining :: [String]
remaining = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf) [String]
possibleTests)forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) [String]
tp
      case [String]
remaining of
          [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          [String]
fs -> forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Some test files do not occur in the selected modules: " forall a. [a] -> [a] -> [a]
++
                                forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [String]
fs) forall a. [a] -> [a] -> [a]
++ String
"\n"
    processResults :: a -> a -> TrackedErrors () -> TrackedErrorsT m ()
processResults a
passed a
failed TrackedErrors ()
rs
      | forall (t :: (* -> *) -> * -> *) a.
(ErrorContextT t, ErrorContextM (t Identity)) =>
t Identity a -> Bool
isCompilerError TrackedErrors ()
rs =
        (forall (m :: * -> *) a.
Monad m =>
TrackedErrors a -> TrackedErrorsT m a
fromTrackedErrors TrackedErrors ()
rs) forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<!!
          String
"\nPassed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
passed forall a. [a] -> [a] -> [a]
++ String
" test(s), Failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
failed forall a. [a] -> [a] -> [a]
++ String
" test(s)"
      | Bool
otherwise =
        forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"\nPassed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
passed forall a. [a] -> [a] -> [a]
++ String
" test(s), Failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
failed forall a. [a] -> [a] -> [a]
++ String
" test(s)"

runCompiler r
resolver b
backend (CompileOptions HelpMode
_ [String]
is [String]
is2 [String]
_ [ExtraSource]
_ [String]
_ String
p (CompileFast CategoryName
c FunctionName
fn String
f2) ForceMode
f Int
pn) = do
  String
dir <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
mkdtemp String
"/tmp/zfast_"
  String
absolute <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
p
  String
f2' <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String
p String -> String -> String
</> String
f2)
  let rm :: ModuleConfig
rm = ModuleConfig {
    mcRoot :: String
mcRoot = String
"",
    mcPath :: String
mcPath = String
".",
    mcExtra :: [String]
mcExtra = [],
    mcExprMap :: [(MacroName, Expression SourceContext)]
mcExprMap = [],
    mcPublicDeps :: [String]
mcPublicDeps = [],
    mcPrivateDeps :: [String]
mcPrivateDeps = [],
    mcExtraFiles :: [ExtraSource]
mcExtraFiles = [],
    mcCategories :: [(CategoryName, CategorySpec SourceContext)]
mcCategories = [],
    mcExtraPaths :: [String]
mcExtraPaths = [],
    mcMode :: CompileMode
mcMode = CompileMode
CompileUnspecified
  }
  ExprMap SourceContext
em <- String -> ModuleConfig -> TrackedErrorsIO (ExprMap SourceContext)
getExprMap String
p ModuleConfig
rm
  let spec :: ModuleSpec
spec = ModuleSpec {
    msRoot :: String
msRoot = String
absolute,
    msPath :: String
msPath = String
dir,
    msExtra :: [String]
msExtra = [],
    msExprMap :: ExprMap SourceContext
msExprMap = ExprMap SourceContext
em,
    msPublicDeps :: [String]
msPublicDeps = [String]
is,
    msPrivateDeps :: [String]
msPrivateDeps = [String]
is2,
    msPublicFiles :: [String]
msPublicFiles = [],
    msPrivateFiles :: [String]
msPrivateFiles = [String
f2'],
    msTestFiles :: [String]
msTestFiles = [],
    msExtraFiles :: [ExtraSource]
msExtraFiles = [],
    msCategories :: [(CategoryName, CategorySpec SourceContext)]
msCategories = [],
    msExtraPaths :: [String]
msExtraPaths = [],
    msMode :: CompileMode
msMode = (CategoryName
-> FunctionName -> LinkerMode -> String -> [String] -> CompileMode
CompileBinary CategoryName
c FunctionName
fn LinkerMode
LinkStatic (String
absolute String -> String -> String
</> forall a. Show a => a -> String
show CategoryName
c) []),
    msForce :: ForceMode
msForce = ForceMode
f,
    msParallel :: Int
msParallel = Int
pn
  }
  forall r b.
(PathIOHandler r, CompilerBackend b) =>
r -> b -> ModuleSpec -> TrackedErrorsIO ()
compileModule r
resolver b
backend ModuleSpec
spec forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In compilation of \"" forall a. [a] -> [a] -> [a]
++ String
f2' forall a. [a] -> [a] -> [a]
++ String
"\""
  forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
dir

runCompiler r
resolver b
backend (CompileOptions HelpMode
_ [String]
_ [String]
_ [String]
ds [ExtraSource]
_ [String]
_ String
p CompileMode
CompileRecompileRecursive ForceMode
f Int
pn) =
  forall r b.
(PathIOHandler r, CompilerBackend b) =>
r
-> b
-> ForceMode
-> Int
-> Bool
-> String
-> [String]
-> TrackedErrorsIO ()
runRecompileCommon r
resolver b
backend ForceMode
f Int
pn Bool
True String
p [String]
ds

runCompiler r
resolver b
backend (CompileOptions HelpMode
_ [String]
_ [String]
_ [String]
ds [ExtraSource]
_ [String]
_ String
p CompileMode
CompileRecompile ForceMode
f Int
pn) =
  forall r b.
(PathIOHandler r, CompilerBackend b) =>
r
-> b
-> ForceMode
-> Int
-> Bool
-> String
-> [String]
-> TrackedErrorsIO ()
runRecompileCommon r
resolver b
backend ForceMode
f Int
pn Bool
False String
p [String]
ds

runCompiler r
resolver b
backend (CompileOptions HelpMode
_ [String]
is [String]
is2 [String]
ds [ExtraSource]
_ [String]
_ String
p CompileMode
CreateTemplates ForceMode
f Int
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> TrackedErrorsIO ()
compileSingle [String]
ds where
  compileSingle :: String -> TrackedErrorsIO ()
compileSingle String
d = do
    VersionHash
compilerHash <- forall b (m :: * -> *).
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> m VersionHash
getCompilerHash b
backend
    String
d' <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String
p String -> String -> String
</> String
d)
    ([String]
ep,[String]
is',[String]
is2',Map CategoryName (CategorySpec SourceContext)
cm) <- String
-> TrackedErrorsT
     IO
     ([String], [String], [String],
      Map CategoryName (CategorySpec SourceContext))
maybeUseConfig String
d'
    [String]
as  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
fixPaths forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m String
resolveModule r
resolver String
d') [String]
is'
    [String]
as2 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
fixPaths forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m String
resolveModule r
resolver String
d') [String]
is2'
    Bool
isBase <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> m Bool
isBaseModule r
resolver String
d'
    [CompileMetadata]
deps1 <- if Bool
isBase
                then VersionHash
-> ForceMode
-> MetadataMap
-> [String]
-> TrackedErrorsIO [CompileMetadata]
loadPublicDeps VersionHash
compilerHash ForceMode
f forall k a. Map k a
Map.empty [String]
as
                else do
                  String
base <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> m String
resolveBaseModule r
resolver
                  VersionHash
-> ForceMode
-> MetadataMap
-> [String]
-> TrackedErrorsIO [CompileMetadata]
loadPublicDeps VersionHash
compilerHash ForceMode
f forall k a. Map k a
Map.empty (String
baseforall a. a -> [a] -> [a]
:[String]
as)
    [CompileMetadata]
deps2 <- VersionHash
-> ForceMode
-> MetadataMap
-> [String]
-> TrackedErrorsIO [CompileMetadata]
loadPublicDeps VersionHash
compilerHash ForceMode
f ([CompileMetadata] -> MetadataMap
mapMetadata [CompileMetadata]
deps1) [String]
as2
    String
path <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
p
    forall r.
PathIOHandler r =>
r
-> String
-> String
-> [String]
-> Map CategoryName (CategorySpec SourceContext)
-> [CompileMetadata]
-> [CompileMetadata]
-> TrackedErrorsIO ()
createModuleTemplates r
resolver String
path String
d [String]
ep Map CategoryName (CategorySpec SourceContext)
cm [CompileMetadata]
deps1 [CompileMetadata]
deps2 forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In module \"" forall a. [a] -> [a] -> [a]
++ String
d' forall a. [a] -> [a] -> [a]
++ String
"\""
  maybeUseConfig :: String
-> TrackedErrorsT
     IO
     ([String], [String], [String],
      Map CategoryName (CategorySpec SourceContext))
maybeUseConfig String
d2 = do
    let rm :: TrackedErrorsIO ModuleConfig
rm = String -> TrackedErrorsIO ModuleConfig
loadRecompile String
d2
    Bool
isError <- forall (m :: * -> *) a. CollectErrorsM m => m a -> m Bool
isCompilerErrorM TrackedErrorsIO ModuleConfig
rm
    if Bool
isError
       then forall (m :: * -> *) a. Monad m => a -> m a
return ([],[String]
is,[String]
is2,forall k a. Map k a
Map.empty)
       else do
         (ModuleConfig String
p2 String
_ [String]
ep [(MacroName, Expression SourceContext)]
_ [String]
is3 [String]
is4  [ExtraSource]
_ [(CategoryName, CategorySpec SourceContext)]
cs [String]
_ CompileMode
_) <- TrackedErrorsIO ModuleConfig
rm
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map ((String
d2 String -> String -> String
</> String
p2) String -> String -> String
</>) [String]
ep,forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [String]
is forall a. [a] -> [a] -> [a]
++ [String]
is3,forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [String]
is2 forall a. [a] -> [a] -> [a]
++ [String]
is4,forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CategoryName, CategorySpec SourceContext)]
cs)

runCompiler r
resolver b
_ (CompileOptions HelpMode
_ [String]
is [String]
is2 [String]
ds [ExtraSource]
es [String]
ep String
p CompileMode
m ForceMode
f Int
_) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> TrackedErrorsIO ()
compileSingle [String]
ds where
  compileSingle :: String -> TrackedErrorsIO ()
compileSingle String
d = do
    [String]
as  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
fixPaths forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *}.
(MonadIO m, CollectErrorsM m) =>
String -> String -> m String
autoDep (String
p String -> String -> String
</> String
d)) [String]
is
    [String]
as2 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> [String]
fixPaths forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *}.
(MonadIO m, CollectErrorsM m) =>
String -> String -> m String
autoDep (String
p String -> String -> String
</> String
d)) [String]
is2
    Bool
isConfigured <- String -> String -> TrackedErrorsIO Bool
isPathConfigured String
p String
d
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isConfigured Bool -> Bool -> Bool
&& ForceMode
f forall a. Eq a => a -> a -> Bool
== ForceMode
DoNotForce) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Module " forall a. [a] -> [a] -> [a]
++ String
d forall a. [a] -> [a] -> [a]
++ String
" has an existing configuration. " forall a. [a] -> [a] -> [a]
++
                       String
"Recompile with -r or use -f to overwrite the config."
    String
absolute <- forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
p
    let rm :: ModuleConfig
rm = ModuleConfig {
      mcRoot :: String
mcRoot = String
absolute,
      mcPath :: String
mcPath = String
d,
      mcExtra :: [String]
mcExtra = [],
      mcExprMap :: [(MacroName, Expression SourceContext)]
mcExprMap = [],
      mcPublicDeps :: [String]
mcPublicDeps = [String]
as,
      mcPrivateDeps :: [String]
mcPrivateDeps = [String]
as2,
      mcExtraFiles :: [ExtraSource]
mcExtraFiles = [ExtraSource]
es,
      mcCategories :: [(CategoryName, CategorySpec SourceContext)]
mcCategories = [],
      mcExtraPaths :: [String]
mcExtraPaths = [String]
ep,
      mcMode :: CompileMode
mcMode = CompileMode
m
    }
    String -> ModuleConfig -> TrackedErrorsIO ()
writeRecompile (String
p String -> String -> String
</> String
d) ModuleConfig
rm
    String
config <- String -> TrackedErrorsT IO String
getRecompilePath (String
p String -> String -> String
</> String
d)
    forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"*** Setup complete. Please edit " forall a. [a] -> [a] -> [a]
++ String
config forall a. [a] -> [a] -> [a]
++ String
" and recompile with zeolite -r. ***"
  autoDep :: String -> String -> m String
autoDep String
p2 String
i = do
    Bool
isSystem <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m Bool
isSystemModule r
resolver String
p2 String
i
    if Bool
isSystem
       then forall (m :: * -> *) a. Monad m => a -> m a
return String
i
       else forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m String
resolveModule r
resolver String
p2 String
i

data TraceEntry =
  TraceEntry {
    TraceEntry -> Integer
teMicroseconds :: Integer,
    TraceEntry -> Integer
teProcess :: Integer,
    TraceEntry -> String
teFunction :: String,
    TraceEntry -> String
teContext :: String
  }

tracesLogHeader :: [String]
tracesLogHeader :: [String]
tracesLogHeader = [String
"microseconds",String
"pid",String
"function",String
"context"]

parseTracesFile :: (FilePath,String) -> TrackedErrorsIO [TraceEntry]
parseTracesFile :: (String, String) -> TrackedErrorsIO [TraceEntry]
parseTracesFile (String
f,String
s) = forall (m :: * -> *) a.
ErrorContextM m =>
TextParser a -> String -> String -> m a
runTextParser (forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between TextParser ()
nullParse TextParser ()
endOfDoc ParsecT CompilerMessage String Identity [TraceEntry]
tracesFile) String
f String
s where
  tracesFile :: ParsecT CompilerMessage String Identity [TraceEntry]
tracesFile =  do
    TextParser ()
parseHeader
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT CompilerMessage String Identity TraceEntry
parseSingle
  parseHeader :: TextParser ()
parseHeader = do
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [String -> TextParser ()
string_ String
","] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TextParser ()
parseColTitle) [String]
tracesLogHeader
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\n' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\r') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  parseSingle :: ParsecT CompilerMessage String Identity TraceEntry
parseSingle = do
    Integer
ms <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd TextParser (Integer, Integer)
parseDec
    String -> TextParser ()
string_ String
","
    Integer
pid <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd TextParser (Integer, Integer)
parseDec
    String -> TextParser ()
string_ String
","
    String
func <- TextParser String
quotedString
    String -> TextParser ()
string_ String
","
    String
c <- TextParser String
quotedString
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\n' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\r') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> String -> String -> TraceEntry
TraceEntry Integer
ms Integer
pid String
func String
c
  parseColTitle :: String -> TextParser ()
parseColTitle String
expected = do
    String
title <- TextParser String
quotedString
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
expected forall a. Eq a => a -> a -> Bool
/= String
title) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"Expected column named \"" forall a. [a] -> [a] -> [a]
++ String
expected forall a. [a] -> [a] -> [a]
++ String
"\" but found \"" forall a. [a] -> [a] -> [a]
++ String
title forall a. [a] -> [a] -> [a]
++ String
"\""

runRecompileCommon :: (PathIOHandler r, CompilerBackend b) => r -> b ->
  ForceMode -> Int -> Bool -> FilePath -> [FilePath] -> TrackedErrorsIO ()
runRecompileCommon :: forall r b.
(PathIOHandler r, CompilerBackend b) =>
r
-> b
-> ForceMode
-> Int
-> Bool
-> String
-> [String]
-> TrackedErrorsIO ()
runRecompileCommon r
resolver b
backend ForceMode
f Int
pn Bool
rec String
p [String]
ds = do
  Set String
explicit <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
canonicalizePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
p String -> String -> String
</>)) [String]
ds
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall {t}.
PathIOHandler t =>
t
-> Set String
-> Set String
-> (String, String)
-> TrackedErrorsT IO (Set String)
recursive r
resolver Set String
explicit) forall a. Set a
Set.empty (forall a b. (a -> b) -> [a] -> [b]
map ((,) String
p) [String]
ds) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return () where
    recursive :: t
-> Set String
-> Set String
-> (String, String)
-> TrackedErrorsT IO (Set String)
recursive t
r Set String
explicit Set String
da (String
p2,String
d0) = do
      String
d <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m String
resolveModule t
r String
p2 String
d0
      Bool
isSystem <- forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> String -> String -> m Bool
isSystemModule t
r String
p2 String
d0
      let process :: Bool
process = if Bool
rec
                       then String
d forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
explicit Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isSystem
                       else String
d forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
explicit
      if Bool -> Bool
not Bool
process Bool -> Bool -> Bool
|| String
d forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
da
         then forall (m :: * -> *) a. Monad m => a -> m a
return Set String
da
         else do
           ModuleConfig
rm <- String -> TrackedErrorsIO ModuleConfig
loadRecompile String
d
           let ds3 :: [(String, String)]
ds3 = forall a b. (a -> b) -> [a] -> [b]
map ((,) String
d) (ModuleConfig -> [String]
mcPublicDeps ModuleConfig
rm forall a. [a] -> [a] -> [a]
++ ModuleConfig -> [String]
mcPrivateDeps ModuleConfig
rm)
           Set String
da' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (t
-> Set String
-> Set String
-> (String, String)
-> TrackedErrorsT IO (Set String)
recursive t
r Set String
explicit) (String
d forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set String
da) [(String, String)]
ds3
           String -> TrackedErrorsIO ()
recompile String
d
           forall (m :: * -> *) a. Monad m => a -> m a
return Set String
da'
    recompile :: String -> TrackedErrorsIO ()
recompile String
d = do
      VersionHash
compilerHash <- forall b (m :: * -> *).
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> m VersionHash
getCompilerHash b
backend
      Bool
upToDate <- VersionHash -> ForceMode -> String -> TrackedErrorsIO Bool
isPathUpToDate VersionHash
compilerHash ForceMode
f String
d
      if ForceMode
f forall a. Ord a => a -> a -> Bool
< ForceMode
ForceAll Bool -> Bool -> Bool
&& Bool
upToDate
         then forall (m :: * -> *). ErrorContextM m => String -> m ()
compilerWarningM forall a b. (a -> b) -> a -> b
$ String
"Path " forall a. [a] -> [a] -> [a]
++ String
d forall a. [a] -> [a] -> [a]
++ String
" is up to date"
         else do
           rm :: ModuleConfig
rm@(ModuleConfig String
p2 String
d2 [String]
ee [(MacroName, Expression SourceContext)]
_ [String]
is [String]
is2 [ExtraSource]
es [(CategoryName, CategorySpec SourceContext)]
cs [String]
ep CompileMode
m) <- String -> TrackedErrorsIO ModuleConfig
loadRecompile String
d
           let fixed :: String
fixed = String -> String
fixPath (String
d String -> String -> String
</> String
p2)
           ([String]
ps,[String]
xs,[String]
ts) <- String
-> [String] -> TrackedErrorsIO ([String], [String], [String])
findSourceFiles String
fixed (String
d2forall a. a -> [a] -> [a]
:[String]
ee)
           ExprMap SourceContext
em <- String -> ModuleConfig -> TrackedErrorsIO (ExprMap SourceContext)
getExprMap String
d ModuleConfig
rm
           let spec :: ModuleSpec
spec = ModuleSpec {
             msRoot :: String
msRoot = String
fixed,
             msPath :: String
msPath = String
d2,
             msExtra :: [String]
msExtra = [String]
ee,
             msExprMap :: ExprMap SourceContext
msExprMap = ExprMap SourceContext
em,
             msPublicDeps :: [String]
msPublicDeps = [String]
is,
             msPrivateDeps :: [String]
msPrivateDeps = [String]
is2,
             msPublicFiles :: [String]
msPublicFiles = [String]
ps,
             msPrivateFiles :: [String]
msPrivateFiles = [String]
xs,
             msTestFiles :: [String]
msTestFiles = [String]
ts,
             msExtraFiles :: [ExtraSource]
msExtraFiles = [ExtraSource]
es,
             msCategories :: [(CategoryName, CategorySpec SourceContext)]
msCategories = [(CategoryName, CategorySpec SourceContext)]
cs,
             msExtraPaths :: [String]
msExtraPaths = [String]
ep,
             msMode :: CompileMode
msMode = CompileMode
m,
             msForce :: ForceMode
msForce = ForceMode
f,
             msParallel :: Int
msParallel = Int
pn
           }
           forall r b.
(PathIOHandler r, CompilerBackend b) =>
r -> b -> ModuleSpec -> TrackedErrorsIO ()
compileModule r
resolver b
backend ModuleSpec
spec forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
"In compilation of module \"" forall a. [a] -> [a] -> [a]
++ String
d forall a. [a] -> [a] -> [a]
++ String
"\""