{- -----------------------------------------------------------------------------
Copyright 2020 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 Safe #-}

module Config.LocalConfig (
  Backend(..),
  LocalConfig(..),
  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 (ProcessStatus(..),executeFile,forkProcess,getProcessStatus)
import System.Posix.Temp (mkstemps)

import Base.CompilerError
import Cli.Programs
import Module.Paths

import Paths_zeolite_lang (getDataFileName,version)


data Backend =
  UnixBackend {
    Backend -> FilePath
ucCxxBinary :: FilePath,
    Backend -> [FilePath]
ucCompileFlags :: [String],
    Backend -> [FilePath]
ucLibraryFlags :: [String],
    Backend -> [FilePath]
ucBinaryFlags :: [String],
    Backend -> FilePath
ucArBinary :: FilePath
  }
  deriving (ReadPrec [Backend]
ReadPrec Backend
Int -> ReadS Backend
ReadS [Backend]
(Int -> ReadS Backend)
-> ReadS [Backend]
-> ReadPrec Backend
-> ReadPrec [Backend]
-> Read Backend
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Backend]
$creadListPrec :: ReadPrec [Backend]
readPrec :: ReadPrec Backend
$creadPrec :: ReadPrec Backend
readList :: ReadS [Backend]
$creadList :: ReadS [Backend]
readsPrec :: Int -> ReadS Backend
$creadsPrec :: Int -> ReadS Backend
Read,Int -> Backend -> ShowS
[Backend] -> ShowS
Backend -> FilePath
(Int -> Backend -> ShowS)
-> (Backend -> FilePath) -> ([Backend] -> ShowS) -> Show Backend
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Backend] -> ShowS
$cshowList :: [Backend] -> ShowS
show :: Backend -> FilePath
$cshow :: Backend -> FilePath
showsPrec :: Int -> Backend -> ShowS
$cshowsPrec :: Int -> Backend -> ShowS
Show)

data Resolver =
  SimpleResolver {
    Resolver -> [FilePath]
srVisibleSystem :: [FilePath],
    Resolver -> [FilePath]
srExtraPaths :: [FilePath]
  }
  deriving (ReadPrec [Resolver]
ReadPrec Resolver
Int -> ReadS Resolver
ReadS [Resolver]
(Int -> ReadS Resolver)
-> ReadS [Resolver]
-> ReadPrec Resolver
-> ReadPrec [Resolver]
-> Read Resolver
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Resolver]
$creadListPrec :: ReadPrec [Resolver]
readPrec :: ReadPrec Resolver
$creadPrec :: ReadPrec Resolver
readList :: ReadS [Resolver]
$creadList :: ReadS [Resolver]
readsPrec :: Int -> ReadS Resolver
$creadsPrec :: Int -> ReadS Resolver
Read,Int -> Resolver -> ShowS
[Resolver] -> ShowS
Resolver -> FilePath
(Int -> Resolver -> ShowS)
-> (Resolver -> FilePath) -> ([Resolver] -> ShowS) -> Show Resolver
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Resolver] -> ShowS
$cshowList :: [Resolver] -> ShowS
show :: Resolver -> FilePath
$cshow :: Resolver -> FilePath
showsPrec :: Int -> Resolver -> ShowS
$cshowsPrec :: Int -> Resolver -> ShowS
Show)

data LocalConfig =
  LocalConfig {
    LocalConfig -> Backend
lcBackend :: Backend,
    LocalConfig -> Resolver
lcResolver :: Resolver
  }
  deriving (ReadPrec [LocalConfig]
ReadPrec LocalConfig
Int -> ReadS LocalConfig
ReadS [LocalConfig]
(Int -> ReadS LocalConfig)
-> ReadS [LocalConfig]
-> ReadPrec LocalConfig
-> ReadPrec [LocalConfig]
-> Read LocalConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LocalConfig]
$creadListPrec :: ReadPrec [LocalConfig]
readPrec :: ReadPrec LocalConfig
$creadPrec :: ReadPrec LocalConfig
readList :: ReadS [LocalConfig]
$creadList :: ReadS [LocalConfig]
readsPrec :: Int -> ReadS LocalConfig
$creadsPrec :: Int -> ReadS LocalConfig
Read,Int -> LocalConfig -> ShowS
[LocalConfig] -> ShowS
LocalConfig -> FilePath
(Int -> LocalConfig -> ShowS)
-> (LocalConfig -> FilePath)
-> ([LocalConfig] -> ShowS)
-> Show LocalConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LocalConfig] -> ShowS
$cshowList :: [LocalConfig] -> ShowS
show :: LocalConfig -> FilePath
$cshow :: LocalConfig -> FilePath
showsPrec :: Int -> LocalConfig -> ShowS
$cshowsPrec :: Int -> LocalConfig -> ShowS
Show)

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

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

instance CompilerBackend Backend where
  runCxxCommand :: Backend -> CxxCommand -> m FilePath
runCxxCommand = Backend -> CxxCommand -> m FilePath
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
Backend -> CxxCommand -> m FilePath
run where
    run :: Backend -> CxxCommand -> m FilePath
run (UnixBackend FilePath
cb [FilePath]
ff [FilePath]
_ [FilePath]
_ FilePath
ab) (CompileToObject FilePath
s FilePath
p [(FilePath, Maybe FilePath)]
ms [FilePath]
ps Bool
e) = do
      FilePath
objName <- IO FilePath -> m FilePath
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
p FilePath -> ShowS
</> (ShowS
takeFileName ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension FilePath
s FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
".o")
      let otherOptions :: [FilePath]
otherOptions = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"-I" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise) [FilePath]
ps [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ((FilePath, Maybe FilePath) -> FilePath)
-> [(FilePath, Maybe FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath) -> FilePath
macro [(FilePath, Maybe FilePath)]
ms
      FilePath -> [FilePath] -> m ()
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
FilePath -> [FilePath] -> m ()
executeProcess FilePath
cb ([FilePath]
ff [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
otherOptions [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-c", FilePath
s, FilePath
"-o", FilePath
objName]) m () -> FilePath -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> FilePath -> m a
<?? FilePath
"In compilation of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
s
      if Bool
e
         then do
           -- Extra files are put into .a since they will be unconditionally
           -- included. This prevents unwanted symbol dependencies.
           FilePath
arName  <- IO FilePath -> m FilePath
forall (m :: * -> *) a. (MonadIO m, ErrorContextM m) => IO a -> m a
errorFromIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
p FilePath -> ShowS
</> (ShowS
takeFileName ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension FilePath
s FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
".a")
           FilePath -> [FilePath] -> m ()
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
FilePath -> [FilePath] -> m ()
executeProcess FilePath
ab [FilePath
"-q",FilePath
arName,FilePath
objName] m () -> FilePath -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> FilePath -> m a
<?? FilePath
"In packaging of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
objName
           FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
arName
         else FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
objName
    run (UnixBackend FilePath
cb [FilePath]
_ [FilePath]
ff [FilePath]
_ FilePath
_) (CompileToShared [FilePath]
ss FilePath
o [FilePath]
lf) = do
      let arFiles :: [FilePath]
arFiles      = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
".a")       [FilePath]
ss
      let otherFiles :: [FilePath]
otherFiles   = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
".a") [FilePath]
ss
      let flags :: [FilePath]
flags = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath]
lf
      let args :: [FilePath]
args = [FilePath]
ff [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
otherFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
arFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-o", FilePath
o] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
flags
      FilePath -> [FilePath] -> m ()
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
FilePath -> [FilePath] -> m ()
executeProcess FilePath
cb [FilePath]
args m () -> FilePath -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> FilePath -> m a
<?? FilePath
"In linking of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
o
      FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
o
    run (UnixBackend FilePath
cb [FilePath]
_ [FilePath]
_ [FilePath]
ff FilePath
_) (CompileToBinary FilePath
m [FilePath]
ss [(FilePath, Maybe FilePath)]
ms FilePath
o [FilePath]
ps [FilePath]
lf) = do
      let arFiles :: [FilePath]
arFiles      = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
".a")       [FilePath]
ss
      let otherFiles :: [FilePath]
otherFiles   = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
".a") [FilePath]
ss
      let otherOptions :: [FilePath]
otherOptions = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"-I" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise) [FilePath]
ps [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ((FilePath, Maybe FilePath) -> FilePath)
-> [(FilePath, Maybe FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath) -> FilePath
macro [(FilePath, Maybe FilePath)]
ms
      let flags :: [FilePath]
flags = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath]
lf
      let args :: [FilePath]
args = [FilePath]
ff [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
otherOptions [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath
mFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
otherFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
arFiles [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-o", FilePath
o] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
flags
      FilePath -> [FilePath] -> m ()
forall (m :: * -> *).
(MonadIO m, ErrorContextM m) =>
FilePath -> [FilePath] -> m ()
executeProcess FilePath
cb [FilePath]
args m () -> FilePath -> m ()
forall (m :: * -> *) a. ErrorContextM m => m a -> FilePath -> m a
<?? FilePath
"In linking of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
o
      FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
o
    macro :: (FilePath, Maybe FilePath) -> FilePath
macro (FilePath
n,Just FilePath
v)  = FilePath
"-D" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
n FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
v
    macro (FilePath
n,Maybe FilePath
Nothing) = FilePath
"-D" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
n
  runTestCommand :: Backend -> TestCommand -> m TestCommandResult
runTestCommand Backend
_ (TestCommand FilePath
b FilePath
p [FilePath]
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
    (FilePath
outF,Handle
outH) <- FilePath -> FilePath -> IO (FilePath, Handle)
mkstemps FilePath
"/tmp/ztest_" FilePath
".txt"
    (FilePath
errF,Handle
errH) <- FilePath -> FilePath -> IO (FilePath, Handle)
mkstemps FilePath
"/tmp/ztest_" FilePath
".txt"
    ProcessID
pid <- IO () -> IO ProcessID
forkProcess (Handle -> Handle -> IO ()
forall b. Handle -> Handle -> IO b
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
    FilePath
out <- FilePath -> IO FilePath
readFile FilePath
outF
    FilePath -> IO ()
removeFile FilePath
outF
    FilePath
err <- FilePath -> IO FilePath
readFile FilePath
errF
    FilePath -> IO ()
removeFile FilePath
errF
    let success :: Bool
success = case Maybe ProcessStatus
status of
                       Just (Exited ExitCode
ExitSuccess) -> Bool
True
                       Maybe ProcessStatus
_ -> Bool
False
    TestCommandResult -> IO TestCommandResult
forall (m :: * -> *) a. Monad m => a -> m a
return (TestCommandResult -> IO TestCommandResult)
-> TestCommandResult -> IO TestCommandResult
forall a b. (a -> b) -> a -> b
$ Bool -> [FilePath] -> [FilePath] -> TestCommandResult
TestCommandResult Bool
success (FilePath -> [FilePath]
lines FilePath
out) (FilePath -> [FilePath]
lines FilePath
err) where
      execWithCapture :: Handle -> Handle -> IO b
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
$ FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
setCurrentDirectory FilePath
p
        Handle -> Handle -> IO ()
hDuplicateTo Handle
h1 Handle
stdout
        Handle -> Handle -> IO ()
hDuplicateTo Handle
h2 Handle
stderr
        FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO b
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
b Bool
True [FilePath]
as Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
  getCompilerHash :: Backend -> VersionHash
getCompilerHash Backend
b = FilePath -> VersionHash
VersionHash (FilePath -> VersionHash) -> FilePath -> VersionHash
forall a b. (a -> b) -> a -> b
$ (Int -> ShowS) -> FilePath -> Int -> FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex FilePath
"" (Int -> FilePath) -> Int -> FilePath
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
$ FilePath -> Int
forall a. Hashable a => a -> Int
hash (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ FilePath
minorVersion FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Backend -> FilePath
forall a. Show a => a -> FilePath
show Backend
b where
    minorVersion :: FilePath
minorVersion = [Int] -> FilePath
forall a. Show a => a -> FilePath
show ([Int] -> FilePath) -> [Int] -> FilePath
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

executeProcess :: (MonadIO m, ErrorContextM m) => String -> [String] -> m ()
executeProcess :: FilePath -> [FilePath] -> m ()
executeProcess FilePath
c [FilePath]
os = 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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Executing: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" " (FilePath
cFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
os)
  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
$ IO () -> IO ProcessID
forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO ()
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
c Bool
True [FilePath]
os Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
  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 (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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Execution of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
c FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" failed"
         FilePath -> m ()
forall (m :: * -> *) a. ErrorContextM m => FilePath -> m a
compilerErrorM (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Execution of " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
c FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" failed"

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

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

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

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