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)--,msrc,modules

import GF.Infra.Ident(ModuleName,moduleNameS)--,showIdent
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) --lookup
import Data.List(nub)
import Data.Time(UTCTime)
import GF.Text.Pretty(render,($$),(<+>),nest)

import PGF.Internal(optimizePGF)
import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)

-- | Compiles a number of source files and builds a 'PGF' structure for them.
-- This is a composition of 'link' and 'batchCompile'.
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 a grammar into a 'PGF' that can be used to 'PGF.linearize' and
-- 'PGF.parse' with the "PGF" run-time system.
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

-- | Returns the name of the abstract syntax corresponding to the named concrete syntax
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

-- | Compile the given grammar files and everything they depend on.
-- Compiled modules are stored in @.gfo@ files (unless the @-tags@ option is
-- used, in which case tags files are produced instead).
-- Existing @.gfo@ files are reused if they are up-to-date
-- (unless the option @-src@ aka @-force-recomp@ is used).
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))
{-
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> Grammar -> IOE Grammar
compileSourceGrammar opts gr = do
  cwd <- getCurrentDirectory
  (_,gr',_) <- foldM (\env -> compileSourceModule opts cwd env Nothing)
                     emptyCompileEnv
                     (modules gr)
  return gr'
-}

-- | compile with one module as starting point
-- command-line options override options (marked by --#) in the file
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.

compileModule :: Options -- ^ Options from program command line and shell command.
              -> 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
--     putIfVerb opts $ "curr_dir:" +++ show curr_dir ----
--     putIfVerb opts $ "lib_dir:" +++ show lib_dirs ----
     [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)
--     putIfVerb opts $ "options from file: " ++ show opts0
--     putIfVerb opts $ "augmented options: " ++ show opts
     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

-- auxiliaries

-- | The environment
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)