{- -----------------------------------------------------------------------------
Copyright 2020-2021 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]

{-# LANGUAGE TypeFamilies #-}

module Config.LocalConfig (
  Backend(..),
  LocalConfig(..),
  PendingProcess,
  Resolver(..),
  rootPath,
  compilerVersion,
) where

import Control.Monad (when)
import Control.Monad.IO.Class
import Data.Hashable (hash)
import Data.List (intercalate,isPrefixOf,isSuffixOf,nub)
import Data.Maybe (isJust)
import Data.Version (showVersion,versionBranch)
import GHC.IO.Handle
import Numeric (showHex)
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Process
import System.Posix.Temp (mkstemps)
import System.Posix.Types (ProcessID)

import Base.CompilerError
import Cli.Programs
import Config.CompilerConfig
import Config.ParseConfig ()
import Module.ParseMetadata
import Module.Paths

import Paths_zeolite_lang (getDataFileName,version)


rootPath :: IO FilePath
rootPath :: IO String
rootPath = String -> IO String
getDataFileName String
""

compilerVersion :: String
compilerVersion :: String
compilerVersion = Version -> String
showVersion Version
version

data PendingProcess =
  PendingProcess {
    PendingProcess -> String
pcContext :: String,
    PendingProcess -> ProcessID
pcProcess :: ProcessID,
    PendingProcess -> Either (IO PendingProcess) String
pcNext :: Either (IO PendingProcess) FilePath
  }

instance CompilerBackend Backend where
  type AsyncWait Backend = PendingProcess
  syncCxxCommand :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend -> CxxCommand -> m String
syncCxxCommand Backend
b CxxCommand
compile = Backend -> CxxCommand -> m (AsyncWait Backend)
forall b (m :: * -> *).
(CompilerBackend b, MonadIO m, CollectErrorsM m) =>
b -> CxxCommand -> m (AsyncWait b)
forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend -> CxxCommand -> m (AsyncWait Backend)
asyncCxxCommand Backend
b CxxCommand
compile m PendingProcess -> (PendingProcess -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PendingProcess -> m String
forall {m :: * -> *}.
(MonadIO m, ErrorContextM m) =>
PendingProcess -> m String
waitAll where
    waitAll :: PendingProcess -> m String
waitAll (PendingProcess String
context ProcessID
pid Either (IO PendingProcess) String
next) = do
      ProcessID -> m ()
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
ProcessID -> m ()
blockProcess ProcessID
pid m () -> String -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
context
      case Either (IO PendingProcess) String
next of
           Left IO PendingProcess
process -> IO PendingProcess -> m PendingProcess
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO IO PendingProcess
process m PendingProcess -> (PendingProcess -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PendingProcess -> m String
waitAll
           Right String
path -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
  asyncCxxCommand :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend -> CxxCommand -> m (AsyncWait Backend)
asyncCxxCommand = Backend -> CxxCommand -> m (AsyncWait Backend)
Backend -> CxxCommand -> m PendingProcess
forall {m :: * -> *}.
(MonadIO m, ErrorContextM m) =>
Backend -> CxxCommand -> m PendingProcess
run where
    run :: Backend -> CxxCommand -> m PendingProcess
run (UnixBackend String
cb [String]
ff [String]
_ [String]
_ String
ab) (CompileToObject String
s String
p [(String, Maybe String)]
ms [String]
ps Bool
e) = do
      String
objName <- IO String -> m String
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
p String -> String -> String
</> (String -> String
takeFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".o")
      String
arName  <- IO String -> m String
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
p String -> String -> String
</> (String -> String
takeFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a")
      let otherOptions :: [String]
otherOptions = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise) [String]
ps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, Maybe String) -> String)
-> [(String, Maybe String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe String) -> String
macro [(String, Maybe String)]
ms
      let next :: Either (IO PendingProcess) String
next = if Bool -> Bool
not Bool
e
                    then String -> Either (IO PendingProcess) String
forall a b. b -> Either a b
Right String
objName
                    else IO PendingProcess -> Either (IO PendingProcess) String
forall a b. a -> Either a b
Left (IO PendingProcess -> Either (IO PendingProcess) String)
-> IO PendingProcess -> Either (IO PendingProcess) String
forall a b. (a -> b) -> a -> b
$ do
                      ProcessID
pid <- String -> [String] -> IO ProcessID
executeProcess String
ab [String
"-q",String
arName,String
objName]
                      PendingProcess -> IO PendingProcess
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PendingProcess -> IO PendingProcess)
-> PendingProcess -> IO PendingProcess
forall a b. (a -> b) -> a -> b
$ PendingProcess {
                          pcContext :: String
pcContext = String
"In archiving of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objName,
                          pcProcess :: ProcessID
pcProcess = ProcessID
pid,
                          pcNext :: Either (IO PendingProcess) String
pcNext = String -> Either (IO PendingProcess) String
forall a b. b -> Either a b
Right String
arName
                        }
      ProcessID
pid <- IO ProcessID -> m ProcessID
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO ProcessID -> m ProcessID) -> IO ProcessID -> m ProcessID
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ProcessID
executeProcess String
cb ([String]
ff [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-c", String
s, String
"-o", String
objName])
      PendingProcess -> m PendingProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PendingProcess -> m PendingProcess)
-> PendingProcess -> m PendingProcess
forall a b. (a -> b) -> a -> b
$ PendingProcess {
          pcContext :: String
pcContext = String
"In compilation of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s,
          pcProcess :: ProcessID
pcProcess = ProcessID
pid,
          pcNext :: Either (IO PendingProcess) String
pcNext = Either (IO PendingProcess) String
next
        }
    run (UnixBackend String
cb [String]
_ [String]
ff [String]
_ String
_) (CompileToShared [String]
ss String
o [String]
lf) = do
      let arFiles :: [String]
arFiles      = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".a")       [String]
ss
      let otherFiles :: [String]
otherFiles   = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".a") [String]
ss
      let flags :: [String]
flags = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
lf
      let args :: [String]
args = [String]
ff [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
arFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-o", String
o] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
flags
      ProcessID
pid <- IO ProcessID -> m ProcessID
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO ProcessID -> m ProcessID) -> IO ProcessID -> m ProcessID
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ProcessID
executeProcess String
cb [String]
args
      PendingProcess -> m PendingProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PendingProcess -> m PendingProcess)
-> PendingProcess -> m PendingProcess
forall a b. (a -> b) -> a -> b
$ PendingProcess {
          pcContext :: String
pcContext = String
"In linking of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o,
          pcProcess :: ProcessID
pcProcess = ProcessID
pid,
          pcNext :: Either (IO PendingProcess) String
pcNext = String -> Either (IO PendingProcess) String
forall a b. b -> Either a b
Right String
o
        }
    run (UnixBackend String
cb [String]
_ [String]
_ [String]
ff String
_) (CompileToBinary String
m [String]
ss [(String, Maybe String)]
ms String
o [String]
ps [String]
lf) = do
      let arFiles :: [String]
arFiles      = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".a")       [String]
ss
      let otherFiles :: [String]
otherFiles   = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".a") [String]
ss
      let otherOptions :: [String]
otherOptions = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise) [String]
ps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, Maybe String) -> String)
-> [(String, Maybe String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe String) -> String
macro [(String, Maybe String)]
ms
      let flags :: [String]
flags = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
lf
      let args :: [String]
args = [String]
ff [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
mString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
otherFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
arFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-o", String
o] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
flags
      ProcessID
pid <- IO ProcessID -> m ProcessID
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO ProcessID -> m ProcessID) -> IO ProcessID -> m ProcessID
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ProcessID
executeProcess String
cb [String]
args
      PendingProcess -> m PendingProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PendingProcess -> m PendingProcess)
-> PendingProcess -> m PendingProcess
forall a b. (a -> b) -> a -> b
$ PendingProcess {
          pcContext :: String
pcContext = String
"In linking of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o,
          pcProcess :: ProcessID
pcProcess = ProcessID
pid,
          pcNext :: Either (IO PendingProcess) String
pcNext = String -> Either (IO PendingProcess) String
forall a b. b -> Either a b
Right String
o
        }
    macro :: (String, Maybe String) -> String
macro (String
n,Just String
v)  = String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
    macro (String
n,Maybe String
Nothing) = String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
  waitCxxCommand :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend
-> AsyncWait Backend -> m (Either (AsyncWait Backend) String)
waitCxxCommand Backend
_ p :: AsyncWait Backend
p@(PendingProcess String
context ProcessID
pid Either (IO PendingProcess) String
next) = do
    Bool
status <- ProcessID -> m Bool
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
ProcessID -> m Bool
waitProcess ProcessID
pid m Bool -> String -> m Bool
forall (m :: * -> *) a. ErrorContextM m => m a -> String -> m a
<?? String
context
    if Bool
status
       then case Either (IO PendingProcess) String
next of
                 Left IO PendingProcess
process -> (PendingProcess -> Either PendingProcess String)
-> m PendingProcess -> m (Either PendingProcess String)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PendingProcess -> Either PendingProcess String
forall a b. a -> Either a b
Left (m PendingProcess -> m (Either PendingProcess String))
-> m PendingProcess -> m (Either PendingProcess String)
forall a b. (a -> b) -> a -> b
$ IO PendingProcess -> m PendingProcess
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO IO PendingProcess
process
                 Right String
result -> Either PendingProcess String -> m (Either PendingProcess String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PendingProcess String -> m (Either PendingProcess String))
-> Either PendingProcess String -> m (Either PendingProcess String)
forall a b. (a -> b) -> a -> b
$ String -> Either PendingProcess String
forall a b. b -> Either a b
Right String
result  -- Not the same Either.
       else Either PendingProcess String -> m (Either PendingProcess String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PendingProcess String -> m (Either PendingProcess String))
-> Either PendingProcess String -> m (Either PendingProcess String)
forall a b. (a -> b) -> a -> b
$ PendingProcess -> Either PendingProcess String
forall a b. a -> Either a b
Left AsyncWait Backend
PendingProcess
p
  runTestCommand :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend -> TestCommand -> m TestCommandResult
runTestCommand Backend
_ (TestCommand String
b String
p [String]
as) = IO TestCommandResult -> m TestCommandResult
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO TestCommandResult -> m TestCommandResult)
-> IO TestCommandResult -> m TestCommandResult
forall a b. (a -> b) -> a -> b
$ do
    (String
outF,Handle
outH) <- String -> String -> IO (String, Handle)
mkstemps String
"/tmp/ztest_" String
".txt"
    (String
errF,Handle
errH) <- String -> String -> IO (String, Handle)
mkstemps String
"/tmp/ztest_" String
".txt"
    ProcessID
pid <- IO () -> IO ProcessID
forkProcess (Handle -> Handle -> IO ()
execWithCapture Handle
outH Handle
errH)
    Handle -> IO ()
hClose Handle
outH
    Handle -> IO ()
hClose Handle
errH
    Maybe ProcessStatus
status <- Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
getProcessStatus Bool
True Bool
True ProcessID
pid
    String
out <- String -> IO String
readFile String
outF
    String -> IO ()
removeFile String
outF
    String
err <- String -> IO String
readFile String
errF
    String -> IO ()
removeFile String
errF
    let success :: Bool
success = case Maybe ProcessStatus
status of
                       Just (Exited ExitCode
ExitSuccess) -> Bool
True
                       Maybe ProcessStatus
_ -> Bool
False
    TestCommandResult -> IO TestCommandResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestCommandResult -> IO TestCommandResult)
-> TestCommandResult -> IO TestCommandResult
forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> [String] -> TestCommandResult
TestCommandResult Bool
success (String -> [String]
lines String
out) (String -> [String]
lines String
err) where
      execWithCapture :: Handle -> Handle -> IO ()
execWithCapture Handle
h1 Handle
h2 = do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
p
        Handle -> Handle -> IO ()
hDuplicateTo Handle
h1 Handle
stdout
        Handle -> Handle -> IO ()
hDuplicateTo Handle
h2 Handle
stderr
        String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
b Bool
True [String]
as Maybe [(String, String)]
forall a. Maybe a
Nothing
  getCompilerHash :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Backend -> m VersionHash
getCompilerHash Backend
b = do
    let minorVersion :: String
minorVersion = [Int] -> String
forall a. Show a => a -> String
show ([Int] -> String) -> [Int] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
3 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
version
    String
serialized <- Backend -> m String
forall a (m :: * -> *).
(ConfigFormat a, CollectErrorsM m) =>
a -> m String
autoWriteConfig Backend
b
    VersionHash -> m VersionHash
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (VersionHash -> m VersionHash) -> VersionHash -> m VersionHash
forall a b. (a -> b) -> a -> b
$ String -> VersionHash
VersionHash (String -> VersionHash) -> String -> VersionHash
forall a b. (a -> b) -> a -> b
$ (Int -> String -> String) -> String -> Int -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> String -> String
forall a. Integral a => a -> String -> String
showHex String
"" (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Hashable a => a -> Int
hash (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
minorVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
serialized

executeProcess :: String -> [String] -> IO ProcessID
executeProcess :: String -> [String] -> IO ProcessID
executeProcess String
c [String]
os = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Executing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
os)
  IO () -> IO ProcessID
forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
c Bool
True [String]
os Maybe [(String, String)]
forall a. Maybe a
Nothing

waitProcess :: (MonadIO m, ErrorContextM m) => ProcessID -> m Bool
waitProcess :: forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
ProcessID -> m Bool
waitProcess ProcessID
pid = do
  Maybe ProcessStatus
status <- IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus)
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
getProcessStatus Bool
False Bool
True ProcessID
pid
  case Maybe ProcessStatus
status of
       Maybe ProcessStatus
Nothing -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
       Just (Exited ExitCode
ExitSuccess) -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       Maybe ProcessStatus
_ -> do
         IO () -> m ()
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Command execution failed"
         String -> m Bool
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String
"Command execution failed"

blockProcess :: (MonadIO m, ErrorContextM m) => ProcessID -> m ()
blockProcess :: forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
ProcessID -> m ()
blockProcess ProcessID
pid = do
  Maybe ProcessStatus
status <- IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus)
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus))
-> IO (Maybe ProcessStatus) -> m (Maybe ProcessStatus)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
getProcessStatus Bool
True Bool
True ProcessID
pid
  case Maybe ProcessStatus
status of
       Just (Exited ExitCode
ExitSuccess) -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Maybe ProcessStatus
_ -> do
         IO () -> m ()
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Command execution failed"
         String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Command execution failed"

instance PathIOHandler Resolver where
  resolveModule :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> String -> String -> m String
resolveModule Resolver
r String
p String
m = do
    [String]
ps2 <- IO [String] -> m [String]
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ Resolver -> String -> IO [String]
potentialSystemPaths Resolver
r String
m
    String -> [String] -> m String
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
String -> [String] -> m String
firstExisting String
m ([String] -> m String) -> [String] -> m String
forall a b. (a -> b) -> a -> b
$ [String
pString -> String -> String
</>String
m] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ps2
  isSystemModule :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> String -> String -> m Bool
isSystemModule Resolver
r String
p String
m = do
    Bool
isDir <- IO Bool -> m Bool
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist (String
pString -> String -> String
</>String
m)
    if Bool
isDir
       then Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
       else do
         [String]
ps2 <- IO [String] -> m [String]
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ Resolver -> String -> IO [String]
potentialSystemPaths Resolver
r String
m
         Maybe String
path <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO ([String] -> IO (Maybe String)
findModule [String]
ps2)
         Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
path
  resolveBaseModule :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> m String
resolveBaseModule Resolver
_ = do
    let m :: String
m = String
"base"
    String
m0 <- IO String -> m String
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getDataFileName String
m
    String -> [String] -> m String
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
String -> [String] -> m String
firstExisting String
m [String
m0]
  isBaseModule :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> String -> m Bool
isBaseModule Resolver
r String
f = do
    String
b <- Resolver -> m String
forall r (m :: * -> *).
(PathIOHandler r, MonadIO m, CollectErrorsM m) =>
r -> m String
forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> m String
resolveBaseModule Resolver
r
    Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b)
  zipWithContents :: forall (m :: * -> *).
(MonadIO m, CollectErrorsM m) =>
Resolver -> String -> [String] -> m [(String, String)]
zipWithContents Resolver
_ String
p [String]
fs = ([String] -> [(String, String)])
-> m [String] -> m [(String, String)]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([String] -> [String] -> [(String, String)])
-> [String] -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
fixPath [String]
fs) (m [String] -> m [(String, String)])
-> m [String] -> m [(String, String)]
forall a b. (a -> b) -> a -> b
$ (String -> m String) -> [String] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO String -> m String
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO String -> m String)
-> (String -> IO String) -> String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
p String -> String -> String
</>)) [String]
fs

potentialSystemPaths :: Resolver -> FilePath -> IO [FilePath]
potentialSystemPaths :: Resolver -> String -> IO [String]
potentialSystemPaths (SimpleResolver [String]
ls [String]
ps) String
m = do
  let allowGlobal :: Bool
allowGlobal = Bool -> Bool
not (String
".." String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
components)
  [String]
m0 <- if Bool
allowGlobal Bool -> Bool -> Bool
&& (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
l -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") String
m) [String]
ls
           then String -> IO String
getDataFileName String
m IO String -> (String -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> (String -> [String]) -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[])
           else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  let m2 :: [String]
m2 = if Bool
allowGlobal
              then (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
</> String
m) [String]
ps
              else []
  [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
m0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
m2 where
    components :: [String]
components = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
stripSlash ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath String
m
    stripSlash :: String -> String
stripSlash = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse

firstExisting :: (MonadIO m, ErrorContextM m) => FilePath -> [FilePath] -> m FilePath
firstExisting :: forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
String -> [String] -> m String
firstExisting String
m [String]
ps = do
  Maybe String
p <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Maybe String)
findModule [String]
ps
  case Maybe String
p of
       Maybe String
Nothing -> String -> m String
forall a. String -> m a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Could not find path " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m
       Just String
p2 -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
p2

findModule :: [FilePath] -> IO (Maybe FilePath)
findModule :: [String] -> IO (Maybe String)
findModule [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
findModule (String
p:[String]
ps) = do
  Bool
isDir <- String -> IO Bool
doesDirectoryExist String
p
  if Bool
isDir
     then (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
p
     else [String] -> IO (Maybe String)
findModule [String]
ps