module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
import GF.Compile.GrammarToPGF(mkCanon2pgf)
import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
importsOfModule)
import GF.CompileOne(compileOne)
import GF.Grammar.Grammar(Grammar,emptyGrammar,
abstractOfConcrete,prependModule)
import GF.Infra.Ident(ModuleName,moduleNameS)
import GF.Infra.Option
import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
justModuleName,extendPathEnv,putStrE,putPointE)
import GF.Data.Operations(raise,(+++),err)
import Control.Monad(foldM,when,(<=<),filterM,liftM)
import GF.System.Directory(doesFileExist,getModificationTime)
import System.FilePath((</>),isRelative,dropFileName)
import qualified Data.Map as Map(empty,insert,elems)
import Data.List(nub)
import Data.Time(UTCTime)
import GF.Text.Pretty(render,($$),(<+>),nest)
import PGF.Internal(optimizePGF)
import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToPGF Options
opts [FilePath]
fs = Options -> (ModuleName, Grammar) -> IOE PGF
link Options
opts ((ModuleName, Grammar) -> IOE PGF)
-> ((UTCTime, (ModuleName, Grammar)) -> (ModuleName, Grammar))
-> (UTCTime, (ModuleName, Grammar))
-> IOE PGF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, (ModuleName, Grammar)) -> (ModuleName, Grammar)
forall a b. (a, b) -> b
snd ((UTCTime, (ModuleName, Grammar)) -> IOE PGF)
-> IO (UTCTime, (ModuleName, Grammar)) -> IOE PGF
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Options -> [FilePath] -> IO (UTCTime, (ModuleName, Grammar))
batchCompile Options
opts [FilePath]
fs
link :: Options -> (ModuleName,Grammar) -> IOE PGF
link :: Options -> (ModuleName, Grammar) -> IOE PGF
link Options
opts (ModuleName
cnc,Grammar
gr) =
Verbosity -> Options -> FilePath -> IOE PGF -> IOE PGF
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Verbosity -> Options -> FilePath -> m b -> m b
putPointE Verbosity
Normal Options
opts FilePath
"linking ... " (IOE PGF -> IOE PGF) -> IOE PGF -> IOE PGF
forall a b. (a -> b) -> a -> b
$ do
let abs :: ModuleName
abs = Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc
PGF
pgf <- Options -> Grammar -> ModuleName -> IOE PGF
mkCanon2pgf Options
opts Grammar
gr ModuleName
abs
Probabilities
probs <- IO Probabilities -> IO Probabilities
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((PGF -> IO Probabilities)
-> (FilePath -> PGF -> IO Probabilities)
-> Maybe FilePath
-> PGF
-> IO Probabilities
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Probabilities -> IO Probabilities
forall (m :: * -> *) a. Monad m => a -> m a
return (Probabilities -> IO Probabilities)
-> (PGF -> Probabilities) -> PGF -> IO Probabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGF -> Probabilities
defaultProbabilities) FilePath -> PGF -> IO Probabilities
readProbabilitiesFromFile ((Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optProbsFile Options
opts) PGF
pgf)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
putStrE FilePath
"OK"
PGF -> IOE PGF
forall (m :: * -> *) a. Monad m => a -> m a
return (PGF -> IOE PGF) -> PGF -> IOE PGF
forall a b. (a -> b) -> a -> b
$ Probabilities -> PGF -> PGF
setProbabilities Probabilities
probs
(PGF -> PGF) -> PGF -> PGF
forall a b. (a -> b) -> a -> b
$ if (Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optOptimizePGF Options
opts then PGF -> PGF
optimizePGF PGF
pgf else PGF
pgf
srcAbsName :: Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc = (FilePath -> ModuleName)
-> (ModuleName -> ModuleName) -> Err ModuleName -> ModuleName
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err (ModuleName -> FilePath -> ModuleName
forall a b. a -> b -> a
const ModuleName
cnc) ModuleName -> ModuleName
forall a. a -> a
id (Err ModuleName -> ModuleName) -> Err ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ Grammar -> ModuleName -> Err ModuleName
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleName
abstractOfConcrete Grammar
gr ModuleName
cnc
batchCompile :: Options -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
batchCompile :: Options -> [FilePath] -> IO (UTCTime, (ModuleName, Grammar))
batchCompile Options
opts [FilePath]
files = do
(Grammar
gr,ModEnv
menv) <- ((Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv))
-> (Grammar, ModEnv) -> [FilePath] -> IO (Grammar, ModEnv)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Options -> (Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv)
compileModule Options
opts) (Grammar, ModEnv)
emptyCompileEnv [FilePath]
files
let cnc :: ModuleName
cnc = FilePath -> ModuleName
moduleNameS (FilePath -> FilePath
justModuleName ([FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
files))
t :: UTCTime
t = [UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([UTCTime] -> UTCTime)
-> ([(UTCTime, [FilePath])] -> [UTCTime])
-> [(UTCTime, [FilePath])]
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, [FilePath]) -> UTCTime)
-> [(UTCTime, [FilePath])] -> [UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime, [FilePath]) -> UTCTime
forall a b. (a, b) -> a
fst ([(UTCTime, [FilePath])] -> UTCTime)
-> [(UTCTime, [FilePath])] -> UTCTime
forall a b. (a -> b) -> a -> b
$ ModEnv -> [(UTCTime, [FilePath])]
forall k a. Map k a -> [a]
Map.elems ModEnv
menv
(UTCTime, (ModuleName, Grammar))
-> IO (UTCTime, (ModuleName, Grammar))
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,(ModuleName
cnc,Grammar
gr))
compileModule :: Options
-> CompileEnv -> FilePath -> IOE CompileEnv
compileModule :: Options -> (Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv)
compileModule Options
opts1 env :: (Grammar, ModEnv)
env@(Grammar
_,ModEnv
rfs) FilePath
file =
do FilePath
file <- FilePath -> IO FilePath
forall (m :: * -> *).
(MonadIO m, Output m, ErrorMonad m) =>
FilePath -> m FilePath
getRealFile FilePath
file
Options
opts0 <- FilePath -> IO Options
forall (m :: * -> *).
(ErrorMonad m, MonadIO m) =>
FilePath -> m Options
getOptionsFromFile FilePath
file
let curr_dir :: FilePath
curr_dir = FilePath -> FilePath
dropFileName FilePath
file
[FilePath]
lib_dirs <- Options -> IO [FilePath]
forall (io :: * -> *). MonadIO io => Options -> io [FilePath]
getLibraryDirectory (Options -> Options -> Options
addOptions Options
opts0 Options
opts1)
let opts :: Options
opts = Options -> Options -> Options
addOptions (FilePath -> [FilePath] -> Options -> Options
fixRelativeLibPaths FilePath
curr_dir [FilePath]
lib_dirs Options
opts0) Options
opts1
[FilePath]
ps0 <- Options -> IO [FilePath]
forall (io :: * -> *). MonadIO io => Options -> io [FilePath]
extendPathEnv Options
opts
let ps :: [FilePath]
ps = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub (FilePath
curr_dir FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
ps0)
Options -> FilePath -> IO ()
forall (f :: * -> *). Output f => Options -> FilePath -> f ()
putIfVerb Options
opts (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"module search path:" FilePath -> FilePath -> FilePath
+++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
ps
[FilePath]
files <- Options -> [FilePath] -> ModEnv -> FilePath -> IO [FilePath]
forall (m :: * -> *).
(ErrorMonad m, MonadIO m, Output m) =>
Options -> [FilePath] -> ModEnv -> FilePath -> m [FilePath]
getAllFiles Options
opts [FilePath]
ps ModEnv
rfs FilePath
file
Options -> FilePath -> IO ()
forall (f :: * -> *). Output f => Options -> FilePath -> f ()
putIfVerb Options
opts (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"files to read:" FilePath -> FilePath -> FilePath
+++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
files
let names :: [FilePath]
names = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
justModuleName [FilePath]
files
Options -> FilePath -> IO ()
forall (f :: * -> *). Output f => Options -> FilePath -> f ()
putIfVerb Options
opts (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"modules to include:" FilePath -> FilePath -> FilePath
+++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
names
((Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv))
-> (Grammar, ModEnv) -> [FilePath] -> IO (Grammar, ModEnv)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Options -> (Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv)
compileOne' Options
opts) (Grammar, ModEnv)
env [FilePath]
files
where
getRealFile :: FilePath -> m FilePath
getRealFile FilePath
file = do
Bool
exists <- FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
file
if Bool
exists
then FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
else if FilePath -> Bool
isRelative FilePath
file
then do
[FilePath]
lib_dirs <- Options -> m [FilePath]
forall (io :: * -> *). MonadIO io => Options -> io [FilePath]
getLibraryDirectory Options
opts1
let candidates :: [FilePath]
candidates = [ FilePath
lib_dir FilePath -> FilePath -> FilePath
</> FilePath
file | FilePath
lib_dir <- [FilePath]
lib_dirs ]
Options -> FilePath -> m ()
forall (f :: * -> *). Output f => Options -> FilePath -> f ()
putIfVerb Options
opts1 (Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (FilePath
"looking for: " FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Int -> [FilePath] -> Doc
forall a. Pretty a => Int -> a -> Doc
nest Int
2 [FilePath]
candidates))
[FilePath]
file1s <- (FilePath -> m Bool) -> [FilePath] -> m [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist [FilePath]
candidates
case [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
file1s of
Int
0 -> FilePath -> m FilePath
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (FilePath
"Unable to find: " FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ Int -> [FilePath] -> Doc
forall a. Pretty a => Int -> a -> Doc
nest Int
2 [FilePath]
candidates))
Int
1 -> do FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
file1s
Int
_ -> do Options -> FilePath -> m ()
forall (f :: * -> *). Output f => Options -> FilePath -> f ()
putIfVerb Options
opts1 (FilePath
"matched multiple candidates: " FilePath -> FilePath -> FilePath
+++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
file1s)
FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
file1s
else FilePath -> m FilePath
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (FilePath
"File" FilePath -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> FilePath
file Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> FilePath
"does not exist"))
compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne' :: Options -> (Grammar, ModEnv) -> FilePath -> IO (Grammar, ModEnv)
compileOne' Options
opts env :: (Grammar, ModEnv)
env@(Grammar
gr,ModEnv
_) = (Grammar, ModEnv)
-> (Maybe FilePath, Module) -> IO (Grammar, ModEnv)
forall (m :: * -> *).
MonadIO m =>
(Grammar, ModEnv)
-> (Maybe FilePath, Module) -> m (Grammar, ModEnv)
extendCompileEnv (Grammar, ModEnv)
env ((Maybe FilePath, Module) -> IO (Grammar, ModEnv))
-> (FilePath -> IO (Maybe FilePath, Module))
-> FilePath
-> IO (Grammar, ModEnv)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Options -> Grammar -> FilePath -> IO (Maybe FilePath, Module)
forall (m :: * -> *).
(Output m, ErrorMonad m, MonadIO m, MonadFail m) =>
Options -> Grammar -> FilePath -> m (Maybe FilePath, Module)
compileOne Options
opts Grammar
gr
type CompileEnv = (Grammar,ModEnv)
emptyCompileEnv :: CompileEnv
emptyCompileEnv :: (Grammar, ModEnv)
emptyCompileEnv = (Grammar
emptyGrammar,ModEnv
forall k a. Map k a
Map.empty)
extendCompileEnv :: (Grammar, ModEnv)
-> (Maybe FilePath, Module) -> m (Grammar, ModEnv)
extendCompileEnv (Grammar
gr,ModEnv
menv) (Maybe FilePath
mfile,Module
mo) =
do ModEnv
menv2 <- case Maybe FilePath
mfile of
Just FilePath
file ->
do let (FilePath
mod,[FilePath]
imps) = Module -> (FilePath, [FilePath])
importsOfModule Module
mo
UTCTime
t <- FilePath -> m UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime FilePath
file
ModEnv -> m ModEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (ModEnv -> m ModEnv) -> ModEnv -> m ModEnv
forall a b. (a -> b) -> a -> b
$ FilePath -> (UTCTime, [FilePath]) -> ModEnv -> ModEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
mod (UTCTime
t,[FilePath]
imps) ModEnv
menv
Maybe FilePath
_ -> ModEnv -> m ModEnv
forall (m :: * -> *) a. Monad m => a -> m a
return ModEnv
menv
(Grammar, ModEnv) -> m (Grammar, ModEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (Grammar -> Module -> Grammar
prependModule Grammar
gr Module
mo,ModEnv
menv2)