-- | Parallel grammar compilation
module GF.CompileInParallel(parallelBatchCompile) where
import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
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
-- Control.Monad.Fail import will become redundant in GHC 8.8+
import qualified Control.Monad.Fail as Fail

-- | Compile the given grammar files and everything they depend on,
-- like 'batchCompile'. This function compiles modules in parallel.
-- It keeps modules compiled in /present/ and /alltenses/ mode apart,
-- storing the @.gfo@ files in separate subdirectories to avoid creating
-- the broken PGF files that can result from mixing different modes in the
-- same concrete syntax.
--
-- The first argument controls the number of jobs to run in
-- parallel. This works if GF was compiled with GHC>=7.6, otherwise you have to
-- use the GHC run-time flag @+RTS -N -RTS@ to enable parallelism.
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
{-
     liftIO $ writeFile (maybe "" id gfoDir</>"paths")
                        (unlines . map (unwords . map rel) . nub $ map snd filepaths)
-}
     [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 --logStrLn = toLog . ePutStrLn
       --ok :: CollectOutput IO a -> IO a
         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
--            logStrLn $ "Finished "++show (length (modules gr'))++" modules."
              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
{-
     liftIO $ writeFile (maybe "" id gfoDir</>"dependencies")
                        (unlines [rel f++": "++unwords (map rel imps)
                                  | (f,imps)<-ds])
-}
     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 --file <- getRealFile file
     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)}
{-
runCO (CO m) = do (o,x) <- m
                  o
                  return x
-}
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)