module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where

import PGF
import PGF.Internal(concretes,optimizePGF,unionPGF)
import PGF.Internal(putSplitAbs,encodeFile,runPut)
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export
import GF.Compile.ConcreteToHaskell(concretes2haskell)
import GF.Compile.GrammarToCanonical--(concretes2canonical)
import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar
import GF.Grammar.BNFC
import GF.Grammar.CFG

--import GF.Infra.Ident(showIdent)
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.ErrM
import GF.System.Directory
import GF.Text.Pretty(render,render80)

import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BSL
import GF.Grammar.CanonicalJSON (encodeJSON)
import System.FilePath
import Control.Monad(when,unless,forM_)

-- | Compile the given GF grammar files. The result is a number of @.gfo@ files
-- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
mainGFC :: Options -> [FilePath] -> IO ()
mainGFC :: Options -> [FilePath] -> IO ()
mainGFC Options
opts [FilePath]
fs = do
  Err ()
r <- IO () -> IO (Err ())
forall a. IOE a -> IO (Err a)
tryIOE (case () of
                 ()
_ | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
fs -> FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"No input files."
                 ()
_ | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (FilePath -> FilePath -> Bool
extensionIs FilePath
".cf")  [FilePath]
fs -> Options -> [FilePath] -> IO ()
compileCFFiles Options
opts [FilePath]
fs
                 ()
_ | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\FilePath
f -> FilePath -> FilePath -> Bool
extensionIs FilePath
".gf" FilePath
f Bool -> Bool -> Bool
|| FilePath -> FilePath -> Bool
extensionIs FilePath
".gfo" FilePath
f)  [FilePath]
fs -> Options -> [FilePath] -> IO ()
compileSourceFiles Options
opts [FilePath]
fs
                 ()
_ | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (FilePath -> FilePath -> Bool
extensionIs FilePath
".pgf") [FilePath]
fs -> Options -> [FilePath] -> IO ()
unionPGFFiles Options
opts [FilePath]
fs
                 ()
_ -> FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Don't know what to do with these input files: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
fs)
  case Err ()
r of
    Ok ()
x    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x
    Bad FilePath
msg -> FilePath -> IO ()
forall a. FilePath -> IO a
die (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ if (Flags -> Verbosity) -> Options -> Verbosity
forall a. (Flags -> a) -> Options -> a
flag Flags -> Verbosity
optVerbosity Options
opts Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Normal
                       then (Char
'\n'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
msg)
                       else FilePath
msg
 where
   extensionIs :: FilePath -> FilePath -> Bool
extensionIs FilePath
ext = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
ext) (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  FilePath -> FilePath
takeExtension

compileSourceFiles :: Options -> [FilePath] -> IOE ()
compileSourceFiles :: Options -> [FilePath] -> IO ()
compileSourceFiles Options
opts [FilePath]
fs = 
    do (UTCTime, [(ModuleName, Grammar)])
output <- Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
batchCompile Options
opts [FilePath]
fs
       (UTCTime, [(ModuleName, Grammar)]) -> IO ()
forall (t :: * -> *) a.
Foldable t =>
(a, t (ModuleName, Grammar)) -> IO ()
exportCanonical (UTCTime, [(ModuleName, Grammar)])
output
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Flags -> Phase) -> Options -> Phase
forall a. (Flags -> a) -> Options -> a
flag Flags -> Phase
optStopAfterPhase Options
opts Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
== Phase
Compile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           Options -> (UTCTime, [(ModuleName, Grammar)]) -> IO ()
linkGrammars Options
opts (UTCTime, [(ModuleName, Grammar)])
output
  where
    batchCompile :: Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
batchCompile = (Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)]))
-> (Maybe Int
    -> Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)]))
-> Maybe (Maybe Int)
-> Options
-> [FilePath]
-> IO (UTCTime, [(ModuleName, Grammar)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
batchCompile' Maybe Int
-> Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
parallelBatchCompile ((Flags -> Maybe (Maybe Int)) -> Options -> Maybe (Maybe Int)
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe (Maybe Int)
optJobs Options
opts)
    batchCompile' :: Options -> [FilePath] -> IO (UTCTime, [(ModuleName, Grammar)])
batchCompile' Options
opts [FilePath]
fs = do (UTCTime
t,(ModuleName, Grammar)
cnc_gr) <- Options -> [FilePath] -> IOE (UTCTime, (ModuleName, Grammar))
S.batchCompile Options
opts [FilePath]
fs
                               (UTCTime, [(ModuleName, Grammar)])
-> IO (UTCTime, [(ModuleName, Grammar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t,[(ModuleName, Grammar)
cnc_gr])

    exportCanonical :: (a, t (ModuleName, Grammar)) -> IO ()
exportCanonical (a
_time, t (ModuleName, Grammar)
canonical) =
      do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutputFormat
FmtHaskell OutputFormat -> [OutputFormat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OutputFormat]
ofmts Bool -> Bool -> Bool
&& Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellConcrete) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           ((ModuleName, Grammar) -> IO ())
-> t (ModuleName, Grammar) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName, Grammar) -> IO ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(ModuleName, Grammar) -> m ()
cnc2haskell t (ModuleName, Grammar)
canonical
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutputFormat
FmtCanonicalGF OutputFormat -> [OutputFormat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OutputFormat]
ofmts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           do Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
False FilePath
"canonical"
              ((ModuleName, Grammar) -> IO ())
-> t (ModuleName, Grammar) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName, Grammar) -> IO ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(ModuleName, Grammar) -> m ()
abs2canonical t (ModuleName, Grammar)
canonical
              ((ModuleName, Grammar) -> IO ())
-> t (ModuleName, Grammar) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName, Grammar) -> IO ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(ModuleName, Grammar) -> m ()
cnc2canonical t (ModuleName, Grammar)
canonical
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutputFormat
FmtCanonicalJson OutputFormat -> [OutputFormat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OutputFormat]
ofmts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((ModuleName, Grammar) -> IO ())
-> t (ModuleName, Grammar) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName, Grammar) -> IO ()
grammar2json t (ModuleName, Grammar)
canonical
      where
        ofmts :: [OutputFormat]
ofmts = (Flags -> [OutputFormat]) -> Options -> [OutputFormat]
forall a. (Flags -> a) -> Options -> a
flag Flags -> [OutputFormat]
optOutputFormats Options
opts

    cnc2haskell :: (ModuleName, Grammar) -> m ()
cnc2haskell (ModuleName
cnc,Grammar
gr) =
      do ((FilePath, FilePath) -> m ()) -> [(FilePath, FilePath)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath, FilePath) -> m ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(FilePath, FilePath) -> m ()
writeExport ([(FilePath, FilePath)] -> m ()) -> [(FilePath, FilePath)] -> m ()
forall a b. (a -> b) -> a -> b
$ Options -> ModuleName -> Grammar -> [(FilePath, FilePath)]
concretes2haskell Options
opts (Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc) Grammar
gr

    abs2canonical :: (ModuleName, Grammar) -> m ()
abs2canonical (ModuleName
cnc,Grammar
gr) =
        (FilePath, FilePath) -> m ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(FilePath, FilePath) -> m ()
writeExport (FilePath
"canonical/"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
render ModuleName
absnameFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
".gf",Abstract -> FilePath
forall a. Pretty a => a -> FilePath
render80 Abstract
canAbs)
      where
        absname :: ModuleName
absname = Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc
        canAbs :: Abstract
canAbs = ModuleName -> Grammar -> Abstract
abstract2canonical ModuleName
absname Grammar
gr

    cnc2canonical :: (ModuleName, Grammar) -> m ()
cnc2canonical (ModuleName
cnc,Grammar
gr) =
      ((FilePath, Concrete) -> m ()) -> [(FilePath, Concrete)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath, FilePath) -> m ()
forall (m :: * -> *).
(Output m, MonadIO m) =>
(FilePath, FilePath) -> m ()
writeExport((FilePath, FilePath) -> m ())
-> ((FilePath, Concrete) -> (FilePath, FilePath))
-> (FilePath, Concrete)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Concrete -> FilePath)
-> (FilePath, Concrete) -> (FilePath, FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Concrete -> FilePath
forall a. Pretty a => a -> FilePath
render80) ([(FilePath, Concrete)] -> m ()) -> [(FilePath, Concrete)] -> m ()
forall a b. (a -> b) -> a -> b
$
            Options -> ModuleName -> Grammar -> [(FilePath, Concrete)]
concretes2canonical Options
opts (Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc) Grammar
gr

    grammar2json :: (ModuleName, Grammar) -> IO ()
grammar2json (ModuleName
cnc,Grammar
gr) = FilePath -> Grammar -> IO ()
encodeJSON (ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
render ModuleName
absname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".json") Grammar
gr_canon
      where absname :: ModuleName
absname = Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc
            gr_canon :: Grammar
gr_canon = Options -> ModuleName -> Grammar -> Grammar
grammar2canonical Options
opts ModuleName
absname Grammar
gr

    writeExport :: (FilePath, FilePath) -> m ()
writeExport (FilePath
path,FilePath
s) = Options -> FilePath -> IO () -> m ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
path (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeUTF8File FilePath
path FilePath
s


-- | Create a @.pgf@ file (and possibly files in other formats, if specified
-- in the 'Options') from the output of 'parallelBatchCompile'.
-- If a @.pgf@ file by the same name already exists and it is newer than the
-- source grammar files (as indicated by the 'UTCTime' argument), it is not
-- recreated. Calls 'writePGF' and 'writeOutputs'.
linkGrammars :: Options -> (UTCTime, [(ModuleName, Grammar)]) -> IO ()
linkGrammars Options
opts (UTCTime
t_src,~cnc_grs :: [(ModuleName, Grammar)]
cnc_grs@(~(ModuleName
cnc,Grammar
gr):[(ModuleName, Grammar)]
_)) =
    do let abs :: FilePath
abs = ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
render (Grammar -> ModuleName -> ModuleName
srcAbsName Grammar
gr ModuleName
cnc)
           pgfFile :: FilePath
pgfFile = Options -> FilePath -> FilePath
outputPath Options
opts (Options -> FilePath -> FilePath
grammarName' Options
opts FilePath
absFilePath -> FilePath -> FilePath
<.>FilePath
"pgf")
       Maybe UTCTime
t_pgf <- if Options -> Bool
outputJustPGF Options
opts
                then IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a. MonadIO f => IO a -> f (Maybe a)
maybeIO (IO UTCTime -> IO (Maybe UTCTime))
-> IO UTCTime -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime FilePath
pgfFile
                else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
       if Maybe UTCTime
t_pgf Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t_src
         then 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
pgfFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is up-to-date."
         else do [PGF]
pgfs <- ((ModuleName, Grammar) -> IO PGF)
-> [(ModuleName, Grammar)] -> IO [PGF]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> (ModuleName, Grammar) -> IO PGF
link Options
opts) [(ModuleName, Grammar)]
cnc_grs
                 let pgf0 :: PGF
pgf0 = (PGF -> PGF -> PGF) -> [PGF] -> PGF
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 PGF -> PGF -> PGF
unionPGF [PGF]
pgfs
                 Probabilities
probs <- (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
pgf0
                 let pgf :: PGF
pgf = Probabilities -> PGF -> PGF
setProbabilities Probabilities
probs PGF
pgf0
                 Options -> PGF -> IO ()
writePGF Options
opts PGF
pgf
                 Options -> PGF -> IO ()
writeOutputs Options
opts PGF
pgf

compileCFFiles :: Options -> [FilePath] -> IOE ()
compileCFFiles :: Options -> [FilePath] -> IO ()
compileCFFiles Options
opts [FilePath]
fs = do
  [BNFCRule]
bnfc_rules <- ([[BNFCRule]] -> [BNFCRule]) -> IO [[BNFCRule]] -> IO [BNFCRule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[BNFCRule]] -> [BNFCRule]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[BNFCRule]] -> IO [BNFCRule])
-> IO [[BNFCRule]] -> IO [BNFCRule]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO [BNFCRule]) -> [FilePath] -> IO [[BNFCRule]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> FilePath -> IO [BNFCRule]
getBNFCRules Options
opts) [FilePath]
fs
  let rules :: [ParamCFRule]
rules = [BNFCRule] -> [ParamCFRule]
bnfc2cf [BNFCRule]
bnfc_rules
  (FilePath, [Int])
startCat <- case [ParamCFRule]
rules of
                (Rule (FilePath, [Int])
cat [Symbol (FilePath, [Int]) FilePath]
_ CFTerm
_ : [ParamCFRule]
_) -> (FilePath, [Int]) -> IO (FilePath, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath, [Int])
cat
                [ParamCFRule]
_                  -> FilePath -> IO (FilePath, [Int])
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"empty CFG"
  let pgf :: PGF
pgf = FilePath -> ParamCFG -> PGF
cf2pgf ([FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
fs) ((FilePath, [Int])
-> Set (FilePath, [Int]) -> [ParamCFRule] -> ParamCFG
forall c t.
(Ord c, Ord t) =>
c -> Set c -> [Rule c t] -> Grammar c t
mkCFG (FilePath, [Int])
startCat Set (FilePath, [Int])
forall a. Set a
Set.empty [ParamCFRule]
rules)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Flags -> Phase) -> Options -> Phase
forall a. (Flags -> a) -> Options -> a
flag Flags -> Phase
optStopAfterPhase Options
opts Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
== Phase
Compile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
     do 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)
        let pgf' :: PGF
pgf' = 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
        Options -> PGF -> IO ()
writePGF Options
opts PGF
pgf'
        Options -> PGF -> IO ()
writeOutputs Options
opts PGF
pgf'

unionPGFFiles :: Options -> [FilePath] -> IOE ()
unionPGFFiles :: Options -> [FilePath] -> IO ()
unionPGFFiles Options
opts [FilePath]
fs =
    if Options -> Bool
outputJustPGF Options
opts
    then IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
doIt FilePath -> IO ()
checkFirst ((Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optName Options
opts)
    else IO ()
doIt
  where
    checkFirst :: FilePath -> IO ()
checkFirst FilePath
name =
      do let pgfFile :: FilePath
pgfFile = Options -> FilePath -> FilePath
outputPath Options
opts (FilePath
name FilePath -> FilePath -> FilePath
<.> FilePath
"pgf")
         UTCTime
sourceTime <- [UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([UTCTime] -> UTCTime) -> IO [UTCTime] -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (FilePath -> IO UTCTime) -> [FilePath] -> IO [UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime [FilePath]
fs
         Maybe UTCTime
targetTime <- IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a. MonadIO f => IO a -> f (Maybe a)
maybeIO (IO UTCTime -> IO (Maybe UTCTime))
-> IO UTCTime -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime FilePath
pgfFile
         if Maybe UTCTime
targetTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
sourceTime
           then 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
pgfFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is up-to-date."
           else IO ()
doIt

    doIt :: IO ()
doIt =
      do [PGF]
pgfs <- (FilePath -> IO PGF) -> [FilePath] -> IO [PGF]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO PGF
forall (m :: * -> *). (Output m, MonadIO m) => FilePath -> m PGF
readPGFVerbose [FilePath]
fs
         let pgf0 :: PGF
pgf0 = (PGF -> PGF -> PGF) -> [PGF] -> PGF
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 PGF -> PGF -> PGF
unionPGF [PGF]
pgfs
             pgf1 :: PGF
pgf1 = if (Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optOptimizePGF Options
opts then PGF -> PGF
optimizePGF PGF
pgf0 else PGF
pgf0
         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
pgf1)
         let pgf :: PGF
pgf  = Probabilities -> PGF -> PGF
setProbabilities Probabilities
probs PGF
pgf1
             pgfFile :: FilePath
pgfFile = Options -> FilePath -> FilePath
outputPath Options
opts (Options -> PGF -> FilePath
grammarName Options
opts PGF
pgf FilePath -> FilePath -> FilePath
<.> FilePath
"pgf")
         if FilePath
pgfFile FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
fs
           then FilePath -> IO ()
forall (m :: * -> *). Output m => FilePath -> m ()
putStrLnE (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Refusing to overwrite " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pgfFile
           else Options -> PGF -> IO ()
writePGF Options
opts PGF
pgf
         Options -> PGF -> IO ()
writeOutputs Options
opts PGF
pgf

    readPGFVerbose :: FilePath -> m PGF
readPGFVerbose FilePath
f =
        Verbosity -> Options -> FilePath -> m PGF -> m PGF
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Verbosity -> Options -> FilePath -> m b -> m b
putPointE Verbosity
Normal Options
opts (FilePath
"Reading " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"...") (m PGF -> m PGF) -> m PGF -> m PGF
forall a b. (a -> b) -> a -> b
$ IO PGF -> m PGF
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PGF -> m PGF) -> IO PGF -> m PGF
forall a b. (a -> b) -> a -> b
$ FilePath -> IO PGF
readPGF FilePath
f

-- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
-- Calls 'exportPGF'.
writeOutputs :: Options -> PGF -> IOE ()
writeOutputs :: Options -> PGF -> IO ()
writeOutputs Options
opts PGF
pgf = do
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Options -> FilePath -> FilePath -> IO ()
writeOutput Options
opts FilePath
name FilePath
str 
                 | OutputFormat
fmt <- (Flags -> [OutputFormat]) -> Options -> [OutputFormat]
forall a. (Flags -> a) -> Options -> a
flag Flags -> [OutputFormat]
optOutputFormats Options
opts,
                   (FilePath
name,FilePath
str) <- Options -> OutputFormat -> PGF -> [(FilePath, FilePath)]
exportPGF Options
opts OutputFormat
fmt PGF
pgf]

-- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
-- 'link') to a @.pgf@ file.
-- A split PGF file is output if the @-split-pgf@ option is used.
writePGF :: Options -> PGF -> IOE ()
writePGF :: Options -> PGF -> IO ()
writePGF Options
opts PGF
pgf =
    if (Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optSplitPGF Options
opts then IO ()
writeSplitPGF else IO ()
writeNormalPGF
  where
    writeNormalPGF :: IO ()
writeNormalPGF =
       do let outfile :: FilePath
outfile = Options -> FilePath -> FilePath
outputPath Options
opts (Options -> PGF -> FilePath
grammarName Options
opts PGF
pgf FilePath -> FilePath -> FilePath
<.> FilePath
"pgf")
          Options -> FilePath -> IO () -> IO ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
outfile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> PGF -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
outfile PGF
pgf

    writeSplitPGF :: IO ()
writeSplitPGF =
      do let outfile :: FilePath
outfile = Options -> FilePath -> FilePath
outputPath Options
opts (Options -> PGF -> FilePath
grammarName Options
opts PGF
pgf FilePath -> FilePath -> FilePath
<.> FilePath
"pgf")
         Options -> FilePath -> IO () -> IO ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
outfile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
outfile (Put -> ByteString
runPut (PGF -> Put
putSplitAbs PGF
pgf))
                                --encodeFile_ outfile (putSplitAbs pgf)
         [(CId, Concr)] -> ((CId, Concr) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map CId Concr -> [(CId, Concr)]
forall k a. Map k a -> [(k, a)]
Map.toList (PGF -> Map CId Concr
concretes PGF
pgf)) (((CId, Concr) -> IO ()) -> IO ())
-> ((CId, Concr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CId, Concr)
cnc -> do
           let outfile :: FilePath
outfile = Options -> FilePath -> FilePath
outputPath Options
opts (CId -> FilePath
showCId ((CId, Concr) -> CId
forall a b. (a, b) -> a
fst (CId, Concr)
cnc) FilePath -> FilePath -> FilePath
<.> FilePath
"pgf_c")
           Options -> FilePath -> IO () -> IO ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
outfile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (CId, Concr) -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
outfile (CId, Concr)
cnc


writeOutput :: Options -> FilePath-> String -> IOE ()
writeOutput :: Options -> FilePath -> FilePath -> IO ()
writeOutput Options
opts FilePath
file FilePath
str = Options -> FilePath -> IO () -> IO ()
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
path (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeUTF8File FilePath
path FilePath
str
  where path :: FilePath
path = Options -> FilePath -> FilePath
outputPath Options
opts FilePath
file

-- * Useful helper functions

grammarName :: Options -> PGF -> String
grammarName :: Options -> PGF -> FilePath
grammarName Options
opts PGF
pgf = Options -> FilePath -> FilePath
grammarName' Options
opts (CId -> FilePath
showCId (PGF -> CId
abstractName PGF
pgf))
grammarName' :: Options -> FilePath -> FilePath
grammarName' Options
opts FilePath
abs = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
abs ((Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optName Options
opts)

outputJustPGF :: Options -> Bool
outputJustPGF Options
opts = [OutputFormat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Flags -> [OutputFormat]) -> Options -> [OutputFormat]
forall a. (Flags -> a) -> Options -> a
flag Flags -> [OutputFormat]
optOutputFormats Options
opts) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optSplitPGF Options
opts)

outputPath :: Options -> FilePath -> FilePath
outputPath Options
opts FilePath
file = (FilePath -> FilePath)
-> (FilePath -> FilePath -> FilePath)
-> Maybe FilePath
-> FilePath
-> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath -> FilePath
forall a. a -> a
id FilePath -> FilePath -> FilePath
(</>) ((Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optOutputDir Options
opts) FilePath
file

writing :: Options -> FilePath -> IO b -> m b
writing Options
opts FilePath
path IO b
io =
    Verbosity -> Options -> FilePath -> m b -> m b
forall (m :: * -> *) b.
(Output m, MonadIO m) =>
Verbosity -> Options -> FilePath -> m b -> m b
putPointE Verbosity
Normal Options
opts (FilePath
"Writing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"...") (m b -> m b) -> m b -> m b
forall a b. (a -> b) -> a -> b
$ IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO b
io