module GF.CompileInParallel(parallelBatchCompile) where
import Prelude hiding (catch,(<>))
import Control.Monad(join,ap,when,unless)
import Control.Applicative
import GF.Infra.Concurrency
import GF.System.Concurrency
import System.FilePath
import qualified GF.System.Directory as D
import GF.System.Catch(catch,try)
import Data.List(nub,isPrefixOf,intercalate,partition)
import qualified Data.Map as M
import GF.Compile.ReadFiles(getOptionsFromFile,findFile,gfImports,gfoImports,VersionTagged(..))
import GF.CompileOne(reuseGFO,useTheSource)
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations
import GF.Grammar.Grammar(emptyGrammar,prependModule)
import GF.Infra.Ident(moduleNameS)
import GF.Text.Pretty
import GF.System.Console(TermColors(..),getTermColors)
import qualified Data.ByteString.Lazy as BS
import qualified Control.Monad.Fail as Fail
parallelBatchCompile :: Maybe Int
-> Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
parallelBatchCompile Maybe Int
jobs Options
opts [FilePath]
rootfiles0 =
do Maybe Int -> IO ()
setJobs Maybe Int
jobs
[FilePath]
rootfiles <- (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
canonical [FilePath]
rootfiles0
[FilePath]
lib_dirs1 <- Options -> IO [FilePath]
forall (io :: * -> *). MonadIO io => Options -> io [FilePath]
getLibraryDirectory Options
opts
[FilePath]
lib_dirs2 <- (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
canonical [FilePath]
lib_dirs1
let lib_dir :: FilePath
lib_dir = [FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
lib_dirs2
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
lib_dirs2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn (FilePath
"GF_LIB_PATH defines more than one directory; using the first, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
lib_dir)
[(FilePath, [FilePath])]
filepaths <- (FilePath -> IO (FilePath, [FilePath]))
-> [FilePath] -> IO [(FilePath, [FilePath])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([FilePath] -> Options -> FilePath -> IO (FilePath, [FilePath])
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
[FilePath] -> Options -> FilePath -> m (FilePath, [FilePath])
getPathFromFile [FilePath
lib_dir] Options
opts) [FilePath]
rootfiles
let groups :: [(Options, [(FilePath, [FilePath])])]
groups = FilePath
-> [(FilePath, [FilePath])]
-> [(Options, [(FilePath, [FilePath])])]
forall a.
FilePath -> [(a, [FilePath])] -> [(Options, [(a, [FilePath])])]
groupFiles FilePath
lib_dir [(FilePath, [FilePath])]
filepaths
n :: Int
n = [(Options, [(FilePath, [FilePath])])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Options, [(FilePath, [FilePath])])]
groups
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn FilePath
"Grammar mixes present and alltenses, dividing modules into two groups"
([UTCTime]
ts,[(ModuleName, Grammar)]
sgrs) <- [(UTCTime, (ModuleName, Grammar))]
-> ([UTCTime], [(ModuleName, Grammar)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(UTCTime, (ModuleName, Grammar))]
-> ([UTCTime], [(ModuleName, Grammar)]))
-> IO [(UTCTime, (ModuleName, Grammar))]
-> IO ([UTCTime], [(ModuleName, Grammar)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Options, [(FilePath, [FilePath])])
-> IO (UTCTime, (ModuleName, Grammar)))
-> [(Options, [(FilePath, [FilePath])])]
-> IO [(UTCTime, (ModuleName, Grammar))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath
-> (Options, [(FilePath, [FilePath])])
-> IO (UTCTime, (ModuleName, Grammar))
forall (m :: * -> *).
(MonadIO m, Output m, MonadFail m) =>
FilePath
-> (Options, [(FilePath, [FilePath])])
-> m (UTCTime, (ModuleName, Grammar))
batchCompile1 FilePath
lib_dir) [(Options, [(FilePath, [FilePath])])]
groups
(UTCTime, [(ModuleName, Grammar)])
-> IO (UTCTime, [(ModuleName, Grammar)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [UTCTime]
ts,[(ModuleName, Grammar)]
sgrs)
where
groupFiles :: FilePath -> [(a, [FilePath])] -> [(Options, [(a, [FilePath])])]
groupFiles FilePath
lib_dir [(a, [FilePath])]
filepaths =
if [(Options, [(a, [FilePath])])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Options, [(a, [FilePath])])]
groupsInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1 then [(Options, [(a, [FilePath])])]
groups else [(Options
opts,[(a, [FilePath])]
filepaths)]
where
groups :: [(Options, [(a, [FilePath])])]
groups = ((Options, [(a, [FilePath])]) -> Bool)
-> [(Options, [(a, [FilePath])])] -> [(Options, [(a, [FilePath])])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool)
-> ((Options, [(a, [FilePath])]) -> Bool)
-> (Options, [(a, [FilePath])])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[(a, [FilePath])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([(a, [FilePath])] -> Bool)
-> ((Options, [(a, [FilePath])]) -> [(a, [FilePath])])
-> (Options, [(a, [FilePath])])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Options, [(a, [FilePath])]) -> [(a, [FilePath])]
forall a b. (a, b) -> b
snd) [(Options
opts_p,[(a, [FilePath])]
present),(Options
opts_a,[(a, [FilePath])]
alltenses)]
([(a, [FilePath])]
present,[(a, [FilePath])]
alltenses) = ((a, [FilePath]) -> Bool)
-> [(a, [FilePath])] -> ([(a, [FilePath])], [(a, [FilePath])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a, [FilePath]) -> Bool
forall a. (a, [FilePath]) -> Bool
usesPresent [(a, [FilePath])]
filepaths
gfoDir :: Maybe FilePath
gfoDir = (Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optGFODir Options
opts
gfo :: FilePath
gfo = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" FilePath -> FilePath
forall a. a -> a
id Maybe FilePath
gfoDir
opts_p :: Options
opts_p = FilePath -> Options
setGFO FilePath
"present"
opts_a :: Options
opts_a = FilePath -> Options
setGFO FilePath
"alltenses"
setGFO :: FilePath -> Options
setGFO FilePath
d = Options -> Options -> Options
addOptions Options
opts
((Flags -> Flags) -> Options
modifyFlags ((Flags -> Flags) -> Options) -> (Flags -> Flags) -> Options
forall a b. (a -> b) -> a -> b
$ \ Flags
f->Flags
f{optGFODir :: Maybe FilePath
optGFODir=FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
gfoFilePath -> FilePath -> FilePath
</>FilePath
d)})
usesPresent :: (a, [FilePath]) -> Bool
usesPresent (a
_,[FilePath]
paths) = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
1 [FilePath]
libs[FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
==[FilePath
"present"]
where
libs :: [FilePath]
libs = [FilePath
p|FilePath
path<-[FilePath]
paths,
let (FilePath
d,FilePath
p0) = Int -> FilePath -> (FilePath, FilePath)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n FilePath
path
p :: FilePath
p = FilePath -> FilePath
dropSlash FilePath
p0,
FilePath
dFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
lib_dir,FilePath
p FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
all_modes]
n :: Int
n = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
lib_dir
all_modes :: [FilePath]
all_modes = [FilePath
"alltenses",FilePath
"present"]
dropSlash :: FilePath -> FilePath
dropSlash (Char
'/':FilePath
p) = FilePath
p
dropSlash (Char
'\\':FilePath
p) = FilePath
p
dropSlash FilePath
p = FilePath
p
setJobs :: Maybe Int -> IO ()
setJobs Maybe Int
opt_n =
do Bool
ok <- Maybe Int -> IO Bool
setNumCapabilities Maybe Int
opt_n
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
ok) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"To set the number of concurrent threads"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" you need to use +RTS -N"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath -> (Int -> FilePath) -> Maybe Int -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" Int -> FilePath
forall a. Show a => a -> FilePath
show Maybe Int
opt_n
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\n or recompile GF with ghc>=7.6"
batchCompile1 :: FilePath
-> (Options, [(FilePath, [FilePath])])
-> m (UTCTime, (ModuleName, Grammar))
batchCompile1 FilePath
lib_dir (Options
opts,[(FilePath, [FilePath])]
filepaths) =
do FilePath
cwd <- m FilePath
forall (io :: * -> *). MonadIO io => io FilePath
D.getCurrentDirectory
let rel :: FilePath -> FilePath
rel = FilePath -> FilePath -> FilePath -> FilePath
relativeTo FilePath
lib_dir FilePath
cwd
prelude_dir :: FilePath
prelude_dir = FilePath
lib_dirFilePath -> FilePath -> FilePath
</>FilePath
"prelude"
gfoDir :: Maybe FilePath
gfoDir = (Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optGFODir Options
opts
m () -> (FilePath -> m ()) -> Maybe FilePath -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Bool -> FilePath -> m ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
D.createDirectoryIfMissing Bool
True) Maybe FilePath
gfoDir
[FilePath]
prelude_files <- [FilePath]
-> ([FilePath] -> [FilePath]) -> Maybe [FilePath] -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [FilePath] -> [FilePath]
forall a. a -> a
id (Maybe [FilePath] -> [FilePath])
-> m (Maybe [FilePath]) -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
IO [FilePath] -> m (Maybe [FilePath])
forall (f :: * -> *) a. MonadIO f => IO a -> f (Maybe a)
maybeIO (FilePath -> IO [FilePath]
forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
D.getDirectoryContents FilePath
prelude_dir)
let fromPrelude :: FilePath -> Bool
fromPrelude FilePath
f = FilePath
lib_dir FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
f Bool -> Bool -> Bool
&&
FilePath -> FilePath
takeFileName FilePath
f FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
prelude_files
ppPath :: [FilePath] -> Doc
ppPath [FilePath]
ps = FilePath
"-path="FilePath -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
":" ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
rel [FilePath]
ps)
MVar (Map FilePath [FilePath])
deps <- Map FilePath [FilePath] -> m (MVar (Map FilePath [FilePath]))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map FilePath [FilePath]
forall k a. Map k a
M.empty
IO () -> IO ()
toLog <- (IO () -> IO ()) -> m (IO () -> IO ())
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(MonadIO m1, MonadIO m2) =>
(a -> IO b) -> m1 (a -> m2 ())
newLog IO () -> IO ()
forall a. a -> a
id
TermColors
term <- m TermColors
forall (m :: * -> *). MonadIO m => m TermColors
getTermColors
let
ok :: CollectOutput IO b -> IO b
ok (CO IO (IO (), b)
m) = (FilePath -> IO b)
-> ((IO (), b) -> IO b) -> Err (IO (), b) -> IO b
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err FilePath -> IO b
forall b. FilePath -> IO b
bad (IO (), b) -> IO b
forall b. (IO (), b) -> IO b
good (Err (IO (), b) -> IO b) -> IO (Err (IO (), b)) -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (IO (), b) -> IO (Err (IO (), b))
forall a. IOE a -> IO (Err a)
tryIOE IO (IO (), b)
m
where
good :: (IO (), b) -> IO b
good (IO ()
o,b
r) = do IO () -> IO ()
toLog IO ()
o; b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
bad :: FilePath -> IO b
bad FilePath
e = do IO () -> IO ()
toLog (FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
redPutStrLn FilePath
e); FilePath -> IO b
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"failed"
redPutStrLn :: FilePath -> m ()
redPutStrLn FilePath
s = do FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr (TermColors -> FilePath
redFg TermColors
term);FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr FilePath
s
FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn (TermColors -> FilePath
restore TermColors
term)
MVar Grammar
sgr <- IO (MVar Grammar) -> m (MVar Grammar)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar Grammar) -> m (MVar Grammar))
-> IO (MVar Grammar) -> m (MVar Grammar)
forall a b. (a -> b) -> a -> b
$ Grammar -> IO (MVar Grammar)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Grammar
emptyGrammar
let extendSgr :: MVar Grammar -> (ModuleName, ModuleInfo) -> IO ()
extendSgr MVar Grammar
sgr (ModuleName, ModuleInfo)
m =
MVar Grammar -> (Grammar -> IO Grammar) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Grammar
sgr ((Grammar -> IO Grammar) -> IO ())
-> (Grammar -> IO Grammar) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Grammar
gr ->
do let gr' :: Grammar
gr' = Grammar -> (ModuleName, ModuleInfo) -> Grammar
prependModule Grammar
gr (ModuleName, ModuleInfo)
m
Grammar -> IO Grammar
forall (m :: * -> *) a. Monad m => a -> m a
return Grammar
gr'
IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
fcache <- IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
-> m (IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
-> m (IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))))
-> IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
-> m (IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
forall a b. (a -> b) -> a -> b
$ (IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
-> (FilePath, Hide (FilePath, [FilePath]))
-> IO (FilePath, (FilePath, [FilePath])))
-> IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
forall (m :: * -> *) k res.
MonadIO m =>
(IOCache k res -> k -> IO res) -> m (IOCache k res)
newIOCache ((IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
-> (FilePath, Hide (FilePath, [FilePath]))
-> IO (FilePath, (FilePath, [FilePath])))
-> IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))))
-> (IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
-> (FilePath, Hide (FilePath, [FilePath]))
-> IO (FilePath, (FilePath, [FilePath])))
-> IO
(IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath])))
forall a b. (a -> b) -> a -> b
$ \ IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
_ (FilePath
imp,Hide (FilePath
f,[FilePath]
ps)) ->
do (FilePath
file,Maybe UTCTime
_,Maybe UTCTime
_) <- Maybe FilePath
-> [FilePath]
-> FilePath
-> IO (FilePath, Maybe UTCTime, Maybe UTCTime)
forall (m :: * -> *).
(MonadIO m, ErrorMonad m) =>
Maybe FilePath
-> [FilePath]
-> FilePath
-> m (FilePath, Maybe UTCTime, Maybe UTCTime)
findFile Maybe FilePath
gfoDir [FilePath]
ps FilePath
imp
(FilePath, (FilePath, [FilePath]))
-> IO (FilePath, (FilePath, [FilePath]))
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
file,(FilePath
f,[FilePath]
ps))
let find :: FilePath -> [FilePath] -> FilePath -> m FilePath
find FilePath
f [FilePath]
ps FilePath
imp =
do (FilePath
file',(FilePath
f',[FilePath]
ps')) <- IO (FilePath, (FilePath, [FilePath]))
-> m (FilePath, (FilePath, [FilePath]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, (FilePath, [FilePath]))
-> m (FilePath, (FilePath, [FilePath])))
-> IO (FilePath, (FilePath, [FilePath]))
-> m (FilePath, (FilePath, [FilePath]))
forall a b. (a -> b) -> a -> b
$ IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
-> (FilePath, Hide (FilePath, [FilePath]))
-> IO (FilePath, (FilePath, [FilePath]))
forall k a. Ord k => IOCache k a -> k -> IO a
readIOCache IOCache
(FilePath, Hide (FilePath, [FilePath]))
(FilePath, (FilePath, [FilePath]))
fcache (FilePath
imp,(FilePath, [FilePath]) -> Hide (FilePath, [FilePath])
forall a. a -> Hide a
Hide (FilePath
f,[FilePath]
ps))
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath]
ps'[FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
/=[FilePath]
ps) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
do (FilePath
file,Maybe UTCTime
_,Maybe UTCTime
_) <- Maybe FilePath
-> [FilePath]
-> FilePath
-> m (FilePath, Maybe UTCTime, Maybe UTCTime)
forall (m :: * -> *).
(MonadIO m, ErrorMonad m) =>
Maybe FilePath
-> [FilePath]
-> FilePath
-> m (FilePath, Maybe UTCTime, Maybe UTCTime)
findFile Maybe FilePath
gfoDir [FilePath]
ps FilePath
imp
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
fileFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
file' Bool -> Bool -> Bool
|| (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FilePath -> Bool
fromPrelude [FilePath
file,FilePath
file']) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
do Bool
eq <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ByteString -> ByteString -> Bool)
-> IO ByteString -> IO (ByteString -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
file IO (ByteString -> Bool) -> IO ByteString -> IO Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO ByteString
BS.readFile FilePath
file'
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
eq (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> m ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$
Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (FilePath
"Ambiguous import of"FilePath -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
impDoc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<>FilePath
":") Int
4
(Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (FilePath -> FilePath
rel FilePath
fileFilePath -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
"from"Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath -> FilePath
rel FilePath
f) Int
4 ([FilePath] -> Doc
ppPath [FilePath]
ps)
Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
Doc -> Int -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> Int -> a2 -> Doc
hang (FilePath -> FilePath
rel FilePath
file'FilePath -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
"from"Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath -> FilePath
rel FilePath
f') Int
4 ([FilePath] -> Doc
ppPath [FilePath]
ps'))
FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file'
compile :: IOCache (a, Hide a) a -> (a, a) -> IO a
compile IOCache (a, Hide a) a
cache (a
file,a
paths) = IOCache (a, Hide a) a -> (a, Hide a) -> IO a
forall k a. Ord k => IOCache k a -> k -> IO a
readIOCache IOCache (a, Hide a) a
cache (a
file,a -> Hide a
forall a. a -> Hide a
Hide a
paths)
compile' :: IOCache (FilePath, Hide [FilePath]) (Either a UTCTime)
-> (FilePath, Hide [FilePath]) -> IO (Either IOError UTCTime)
compile' IOCache (FilePath, Hide [FilePath]) (Either a UTCTime)
cache (FilePath
f,Hide [FilePath]
ps) =
IO UTCTime -> IO (Either IOError UTCTime)
forall a. IO a -> IO (Either IOError a)
try (IO UTCTime -> IO (Either IOError UTCTime))
-> IO UTCTime -> IO (Either IOError UTCTime)
forall a b. (a -> b) -> a -> b
$
do let compileImport :: FilePath -> IO (Either a UTCTime)
compileImport FilePath
f = IOCache (FilePath, Hide [FilePath]) (Either a UTCTime)
-> (FilePath, [FilePath]) -> IO (Either a UTCTime)
forall a a a. Ord a => IOCache (a, Hide a) a -> (a, a) -> IO a
compile IOCache (FilePath, Hide [FilePath]) (Either a UTCTime)
cache (FilePath
f,[FilePath]
ps)
findImports :: (FilePath, [FilePath]) -> m [FilePath]
findImports (FilePath
f,[FilePath]
ps) = (FilePath -> m FilePath) -> [FilePath] -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> [FilePath] -> FilePath -> m FilePath
forall (m :: * -> *).
(MonadIO m, ErrorMonad m, MonadFail m) =>
FilePath -> [FilePath] -> FilePath -> m FilePath
find FilePath
f [FilePath]
ps) ([FilePath] -> m [FilePath])
-> ((FilePath, [FilePath]) -> [FilePath])
-> (FilePath, [FilePath])
-> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ((FilePath, [FilePath]) -> [FilePath])
-> (FilePath, [FilePath])
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, [FilePath]) -> [FilePath]
forall a b. (a, b) -> b
snd
((FilePath, [FilePath]) -> m [FilePath])
-> m (FilePath, [FilePath]) -> m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Options -> FilePath -> m (FilePath, [FilePath])
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
Options -> FilePath -> m (FilePath, [FilePath])
getImports Options
opts FilePath
f
[FilePath]
imps <- CollectOutput IO [FilePath] -> IO [FilePath]
forall b. CollectOutput IO b -> IO b
ok ((FilePath, [FilePath]) -> CollectOutput IO [FilePath]
forall (m :: * -> *).
(MonadIO m, ErrorMonad m, MonadFail m) =>
(FilePath, [FilePath]) -> m [FilePath]
findImports (FilePath
f,[FilePath]
ps))
MVar (Map FilePath [FilePath])
-> (Map FilePath [FilePath] -> IO (Map FilePath [FilePath]))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map FilePath [FilePath])
deps (Map FilePath [FilePath] -> IO (Map FilePath [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath [FilePath] -> IO (Map FilePath [FilePath]))
-> (Map FilePath [FilePath] -> Map FilePath [FilePath])
-> Map FilePath [FilePath]
-> IO (Map FilePath [FilePath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> [FilePath] -> Map FilePath [FilePath] -> Map FilePath [FilePath]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
f [FilePath]
imps)
([],[UTCTime]
tis) <- [Either a UTCTime] -> ([a], [UTCTime])
forall a a. [Either a a] -> ([a], [a])
splitEither ([Either a UTCTime] -> ([a], [UTCTime]))
-> IO [Either a UTCTime] -> IO ([a], [UTCTime])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Either a UTCTime))
-> [FilePath] -> IO [Either a UTCTime]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
parMapM FilePath -> IO (Either a UTCTime)
compileImport [FilePath]
imps
let reuse :: FilePath -> IO (UTCTime, (ModuleName, ModuleInfo))
reuse FilePath
gfo = do UTCTime
t <- FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
D.getModificationTime FilePath
gfo
Grammar
gr <- MVar Grammar -> IO Grammar
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar Grammar
sgr
OneOutput
r <- IO OneOutput -> IO OneOutput
forall a. IO a -> IO a
lazyIO (IO OneOutput -> IO OneOutput) -> IO OneOutput -> IO OneOutput
forall a b. (a -> b) -> a -> b
$ CollectOutput IO OneOutput -> IO OneOutput
forall b. CollectOutput IO b -> IO b
ok (Options -> Grammar -> FilePath -> CollectOutput IO OneOutput
forall (m :: * -> *).
(Output m, ErrorMonad m, MonadIO m, MonadFail m) =>
Options -> Grammar -> FilePath -> m OneOutput
reuseGFO Options
opts Grammar
gr FilePath
gfo)
(UTCTime, (ModuleName, ModuleInfo))
-> IO (UTCTime, (ModuleName, ModuleInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,OneOutput -> (ModuleName, ModuleInfo)
forall a b. (a, b) -> b
snd OneOutput
r)
compileSrc :: FilePath -> IO (UTCTime, (ModuleName, ModuleInfo))
compileSrc FilePath
f =
do Grammar
gr <- MVar Grammar -> IO Grammar
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar Grammar
sgr
(Just FilePath
gfo,(ModuleName, ModuleInfo)
mo) <- CollectOutput IO OneOutput -> IO OneOutput
forall b. CollectOutput IO b -> IO b
ok (Options -> Grammar -> FilePath -> CollectOutput IO OneOutput
forall (m :: * -> *).
(Output m, ErrorMonad m, MonadIO m, MonadFail m) =>
Options -> Grammar -> FilePath -> m OneOutput
useTheSource Options
opts Grammar
gr FilePath
f)
UTCTime
t <- FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
D.getModificationTime FilePath
gfo
(UTCTime, (ModuleName, ModuleInfo))
-> IO (UTCTime, (ModuleName, ModuleInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,(ModuleName, ModuleInfo)
mo)
(UTCTime
t,(ModuleName, ModuleInfo)
mo) <- if FilePath -> Bool
isGFO FilePath
f
then FilePath -> IO (UTCTime, (ModuleName, ModuleInfo))
reuse FilePath
f
else do UTCTime
ts <- FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
D.getModificationTime FilePath
f
let gfo :: FilePath
gfo = Maybe FilePath -> FilePath -> FilePath
gf2gfo' Maybe FilePath
gfoDir FilePath
f
Maybe UTCTime
to <- IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a. MonadIO f => IO a -> f (Maybe a)
maybeIO (FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
D.getModificationTime FilePath
gfo)
if Maybe UTCTime
toMaybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>=UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just ([UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (UTCTime
tsUTCTime -> [UTCTime] -> [UTCTime]
forall a. a -> [a] -> [a]
:[UTCTime]
tis))
then FilePath -> IO (UTCTime, (ModuleName, ModuleInfo))
reuse FilePath
gfo
else FilePath -> IO (UTCTime, (ModuleName, ModuleInfo))
compileSrc FilePath
f
MVar Grammar -> (ModuleName, ModuleInfo) -> IO ()
extendSgr MVar Grammar
sgr (ModuleName, ModuleInfo)
mo
UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return ([UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (UTCTime
tUTCTime -> [UTCTime] -> [UTCTime]
forall a. a -> [a] -> [a]
:[UTCTime]
tis))
IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime)
cache <- IO (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
-> m (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
-> m (IOCache
(FilePath, Hide [FilePath]) (Either IOError UTCTime)))
-> IO
(IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
-> m (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
forall a b. (a -> b) -> a -> b
$ (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime)
-> (FilePath, Hide [FilePath]) -> IO (Either IOError UTCTime))
-> IO
(IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime))
forall (m :: * -> *) k res.
MonadIO m =>
(IOCache k res -> k -> IO res) -> m (IOCache k res)
newIOCache IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime)
-> (FilePath, Hide [FilePath]) -> IO (Either IOError UTCTime)
forall a.
IOCache (FilePath, Hide [FilePath]) (Either a UTCTime)
-> (FilePath, Hide [FilePath]) -> IO (Either IOError UTCTime)
compile'
([IOError]
es,[UTCTime]
ts) <- IO ([IOError], [UTCTime]) -> m ([IOError], [UTCTime])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([IOError], [UTCTime]) -> m ([IOError], [UTCTime]))
-> IO ([IOError], [UTCTime]) -> m ([IOError], [UTCTime])
forall a b. (a -> b) -> a -> b
$ [Either IOError UTCTime] -> ([IOError], [UTCTime])
forall a a. [Either a a] -> ([a], [a])
splitEither ([Either IOError UTCTime] -> ([IOError], [UTCTime]))
-> IO [Either IOError UTCTime] -> IO ([IOError], [UTCTime])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, [FilePath]) -> IO (Either IOError UTCTime))
-> [(FilePath, [FilePath])] -> IO [Either IOError UTCTime]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
parMapM (IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime)
-> (FilePath, [FilePath]) -> IO (Either IOError UTCTime)
forall a a a. Ord a => IOCache (a, Hide a) a -> (a, a) -> IO a
compile IOCache (FilePath, Hide [FilePath]) (Either IOError UTCTime)
cache) [(FilePath, [FilePath])]
filepaths
Grammar
gr <- MVar Grammar -> m Grammar
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar Grammar
sgr
let cnc :: ModuleName
cnc = FilePath -> ModuleName
moduleNameS (FilePath -> FilePath
justModuleName ((FilePath, [FilePath]) -> FilePath
forall a b. (a, b) -> a
fst ([(FilePath, [FilePath])] -> (FilePath, [FilePath])
forall a. [a] -> a
last [(FilePath, [FilePath])]
filepaths)))
[(FilePath, [FilePath])]
ds <- Map FilePath [FilePath] -> [(FilePath, [FilePath])]
forall k a. Map k a -> [(k, a)]
M.toList (Map FilePath [FilePath] -> [(FilePath, [FilePath])])
-> m (Map FilePath [FilePath]) -> m [(FilePath, [FilePath])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map FilePath [FilePath]) -> m (Map FilePath [FilePath])
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Map FilePath [FilePath])
deps
FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
putStrLnE (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$
[(FilePath, [FilePath])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FilePath, [FilePath])]
dsInt -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
"modules in"
Doc -> Int -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub (((FilePath, [FilePath]) -> FilePath)
-> [(FilePath, [FilePath])] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
dropFileName(FilePath -> FilePath)
-> ((FilePath, [FilePath]) -> FilePath)
-> (FilePath, [FilePath])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FilePath, [FilePath]) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, [FilePath])]
ds))Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
"directories."
let n :: Int
n = [IOError] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IOError]
es
if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
then FilePath -> m (UTCTime, (ModuleName, Grammar))
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m (UTCTime, (ModuleName, Grammar)))
-> FilePath -> m (UTCTime, (ModuleName, Grammar))
forall a b. (a -> b) -> a -> b
$ FilePath
"Errors prevented "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" module"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Char
's'|Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
1]FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" from being compiled."
else (UTCTime, (ModuleName, Grammar))
-> m (UTCTime, (ModuleName, Grammar))
forall (m :: * -> *) a. Monad m => a -> m a
return ([UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [UTCTime]
ts,(ModuleName
cnc,Grammar
gr))
splitEither :: [Either a a] -> ([a], [a])
splitEither [Either a a]
es = ([a
x|Left a
x<-[Either a a]
es],[a
y|Right a
y<-[Either a a]
es])
canonical :: FilePath -> m FilePath
canonical FilePath
path = IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
D.canonicalizePath FilePath
path IO FilePath -> (IOError -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOError -> IO a) -> IO a
`catch` IO FilePath -> IOError -> IO FilePath
forall a b. a -> b -> a
const (FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path)
getPathFromFile :: [FilePath] -> Options -> FilePath -> m (FilePath, [FilePath])
getPathFromFile [FilePath]
lib_dir Options
cmdline_opts FilePath
file =
do
Options
file_opts <- FilePath -> m Options
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
FilePath -> m Options
getOptionsFromFile FilePath
file
let file_dir :: FilePath
file_dir = FilePath -> FilePath
dropFileName FilePath
file
opts :: Options
opts = Options -> Options -> Options
addOptions (FilePath -> [FilePath] -> Options -> Options
fixRelativeLibPaths FilePath
file_dir [FilePath]
lib_dir Options
file_opts)
Options
cmdline_opts
[FilePath]
paths <- (FilePath -> m FilePath) -> [FilePath] -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> m FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
canonical ([FilePath] -> m [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
file_dir FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) ([FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Options -> m [FilePath]
forall (io :: * -> *). MonadIO io => Options -> io [FilePath]
extendPathEnv Options
opts
(FilePath, [FilePath]) -> m (FilePath, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
file,[FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath]
paths)
getImports :: Options -> FilePath -> m (FilePath, [FilePath])
getImports Options
opts FilePath
file =
if FilePath -> Bool
isGFO FilePath
file then FilePath -> m (FilePath, [FilePath])
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
FilePath -> m (FilePath, [FilePath])
gfoImports' FilePath
file else Options -> FilePath -> m (FilePath, [FilePath])
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
Options -> FilePath -> m (FilePath, [FilePath])
gfImports Options
opts FilePath
file
where
gfoImports' :: FilePath -> m (FilePath, [FilePath])
gfoImports' FilePath
file = VersionTagged (FilePath, [FilePath]) -> m (FilePath, [FilePath])
forall (m :: * -> *) a. ErrorMonad m => VersionTagged a -> m a
check (VersionTagged (FilePath, [FilePath]) -> m (FilePath, [FilePath]))
-> m (VersionTagged (FilePath, [FilePath]))
-> m (FilePath, [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> m (VersionTagged (FilePath, [FilePath]))
forall (f :: * -> *).
MonadIO f =>
FilePath -> f (VersionTagged (FilePath, [FilePath]))
gfoImports FilePath
file
where
check :: VersionTagged a -> m a
check (Tagged a
imps) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
imps
check VersionTagged a
WrongVersion = FilePath -> m a
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (FilePath -> m a) -> FilePath -> m a
forall a b. (a -> b) -> a -> b
$ FilePath
fileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
": .gfo file version mismatch"
relativeTo :: FilePath -> FilePath -> FilePath -> FilePath
relativeTo FilePath
lib_dir FilePath
cwd FilePath
path =
if FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
librelInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
cwdrel then FilePath
librel else FilePath
cwdrel
where
librel :: FilePath
librel = FilePath
"%"FilePath -> FilePath -> FilePath
</>FilePath -> FilePath -> FilePath
makeRelative FilePath
lib_dir FilePath
path
cwdrel :: FilePath
cwdrel = FilePath -> FilePath -> FilePath
makeRelative FilePath
cwd FilePath
path
data IOCache arg res
= IOCache { IOCache arg res -> arg -> IO res
op::arg->IO res,
IOCache arg res -> MVar (Map arg (MVar res))
cache::MVar (M.Map arg (MVar res)) }
newIOCache :: (IOCache k res -> k -> IO res) -> m (IOCache k res)
newIOCache IOCache k res -> k -> IO res
op =
do MVar (Map k (MVar res))
v <- Map k (MVar res) -> m (MVar (Map k (MVar res)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map k (MVar res)
forall k a. Map k a
M.empty
let cache :: IOCache k res
cache = (k -> IO res) -> MVar (Map k (MVar res)) -> IOCache k res
forall arg res.
(arg -> IO res) -> MVar (Map arg (MVar res)) -> IOCache arg res
IOCache (IOCache k res -> k -> IO res
op IOCache k res
cache) MVar (Map k (MVar res))
v
IOCache k res -> m (IOCache k res)
forall (m :: * -> *) a. Monad m => a -> m a
return IOCache k res
cache
readIOCache :: IOCache k a -> k -> IO a
readIOCache (IOCache k -> IO a
op MVar (Map k (MVar a))
cacheVar) k
arg =
IO (IO a) -> IO a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO a) -> IO a) -> IO (IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ MVar (Map k (MVar a))
-> (Map k (MVar a) -> IO (Map k (MVar a), IO a)) -> IO (IO a)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map k (MVar a))
cacheVar ((Map k (MVar a) -> IO (Map k (MVar a), IO a)) -> IO (IO a))
-> (Map k (MVar a) -> IO (Map k (MVar a), IO a)) -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ \ Map k (MVar a)
cache ->
case k -> Map k (MVar a) -> Maybe (MVar a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
arg Map k (MVar a)
cache of
Maybe (MVar a)
Nothing -> do MVar a
v <- IO (MVar a)
forall (io :: * -> *) a. MonadIO io => io (MVar a)
newEmptyMVar
let doit :: IO a
doit = do a
res <- k -> IO a
op k
arg
MVar a -> a -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar a
v a
res
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
(Map k (MVar a), IO a) -> IO (Map k (MVar a), IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> MVar a -> Map k (MVar a) -> Map k (MVar a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
arg MVar a
v Map k (MVar a)
cache,IO a
doit)
Just MVar a
v -> do (Map k (MVar a), IO a) -> IO (Map k (MVar a), IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k (MVar a)
cache,MVar a -> IO a
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar a
v)
newtype Hide a = Hide {Hide a -> a
reveal::a}
instance Eq (Hide a) where Hide a
_ == :: Hide a -> Hide a -> Bool
== Hide a
_ = Bool
True
instance Ord (Hide a) where compare :: Hide a -> Hide a -> Ordering
compare Hide a
_ Hide a
_ = Ordering
EQ
newtype CollectOutput m a = CO {CollectOutput m a -> m (m (), a)
unCO::m (m (),a)}
instance Functor m => Functor (CollectOutput m) where
fmap :: (a -> b) -> CollectOutput m a -> CollectOutput m b
fmap a -> b
f (CO m (m (), a)
m) = m (m (), b) -> CollectOutput m b
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (((m (), a) -> (m (), b)) -> m (m (), a) -> m (m (), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (m (), a) -> (m (), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (m (), a)
m)
instance (Functor m,Monad m) => Applicative (CollectOutput m) where
pure :: a -> CollectOutput m a
pure = a -> CollectOutput m a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: CollectOutput m (a -> b) -> CollectOutput m a -> CollectOutput m b
(<*>) = CollectOutput m (a -> b) -> CollectOutput m a -> CollectOutput m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad m => Monad (CollectOutput m) where
return :: a -> CollectOutput m a
return a
x = m (m (), a) -> CollectOutput m a
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO ((m (), a) -> m (m (), a)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),a
x))
CO m (m (), a)
m >>= :: CollectOutput m a -> (a -> CollectOutput m b) -> CollectOutput m b
>>= a -> CollectOutput m b
f = m (m (), b) -> CollectOutput m b
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (m (m (), b) -> CollectOutput m b)
-> m (m (), b) -> CollectOutput m b
forall a b. (a -> b) -> a -> b
$ do (m ()
o1,a
x) <- m (m (), a)
m
let CO m (m (), b)
m2 = a -> CollectOutput m b
f a
x
(m ()
o2,b
y) <- m (m (), b)
m2
(m (), b) -> m (m (), b)
forall (m :: * -> *) a. Monad m => a -> m a
return (m ()
o1m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>m ()
o2,b
y)
instance MonadIO m => MonadIO (CollectOutput m) where
liftIO :: IO a -> CollectOutput m a
liftIO IO a
io = m (m (), a) -> CollectOutput m a
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (m (m (), a) -> CollectOutput m a)
-> m (m (), a) -> CollectOutput m a
forall a b. (a -> b) -> a -> b
$ do a
x <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io
(m (), a) -> m (m (), a)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),a
x)
instance Output m => Output (CollectOutput m) where
ePutStr :: FilePath -> CollectOutput m ()
ePutStr FilePath
s = m (m (), ()) -> CollectOutput m ()
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO ((m (), ()) -> m (m (), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr FilePath
s,()))
ePutStrLn :: FilePath -> CollectOutput m ()
ePutStrLn FilePath
s = m (m (), ()) -> CollectOutput m ()
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO ((m (), ()) -> m (m (), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn FilePath
s,()))
putStrLnE :: FilePath -> CollectOutput m ()
putStrLnE FilePath
s = m (m (), ()) -> CollectOutput m ()
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO ((m (), ()) -> m (m (), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
putStrLnE FilePath
s,()))
putStrE :: FilePath -> CollectOutput m ()
putStrE FilePath
s = m (m (), ()) -> CollectOutput m ()
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO ((m (), ()) -> m (m (), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
putStrE FilePath
s,()))
instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where
fail :: FilePath -> CollectOutput m a
fail = m (m (), a) -> CollectOutput m a
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (m (m (), a) -> CollectOutput m a)
-> (FilePath -> m (m (), a)) -> FilePath -> CollectOutput m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m (m (), a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail
instance ErrorMonad m => ErrorMonad (CollectOutput m) where
raise :: FilePath -> CollectOutput m a
raise FilePath
e = m (m (), a) -> CollectOutput m a
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (FilePath -> m (m (), a)
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise FilePath
e)
handle :: CollectOutput m a
-> (FilePath -> CollectOutput m a) -> CollectOutput m a
handle (CO m (m (), a)
m) FilePath -> CollectOutput m a
h = m (m (), a) -> CollectOutput m a
forall (m :: * -> *) a. m (m (), a) -> CollectOutput m a
CO (m (m (), a) -> CollectOutput m a)
-> m (m (), a) -> CollectOutput m a
forall a b. (a -> b) -> a -> b
$ m (m (), a) -> (FilePath -> m (m (), a)) -> m (m (), a)
forall (m :: * -> *) a.
ErrorMonad m =>
m a -> (FilePath -> m a) -> m a
handle m (m (), a)
m (CollectOutput m a -> m (m (), a)
forall (m :: * -> *) a. CollectOutput m a -> m (m (), a)
unCO (CollectOutput m a -> m (m (), a))
-> (FilePath -> CollectOutput m a) -> FilePath -> m (m (), a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CollectOutput m a
h)