module GF.Compile.GetGrammar (getSourceModule, getBNFCRules, getEBNFRules) where
import Prelude hiding (catch)
import GF.Data.Operations
import GF.Infra.UseIO
import GF.Infra.Option(Options,optPreprocessors,addOptions,renameEncoding,optEncoding,flag,defaultEncoding)
import GF.Grammar.Lexer
import GF.Grammar.Parser
import GF.Grammar.Grammar
import GF.Grammar.BNFC
import GF.Grammar.EBNF
import GF.Compile.ReadFiles(parseSource)
import qualified Data.ByteString.Char8 as BS
import Data.Char(isAscii)
import Control.Monad (foldM,when,unless)
import System.Process (system)
import GF.System.Directory(removeFile,getCurrentDirectory)
import System.FilePath(makeRelative)
getSourceModule :: Options -> FilePath -> m (ModuleName, ModuleInfo)
getSourceModule Options
opts FilePath
file0 =
do Temporary
tmp <- IO Temporary -> m Temporary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Temporary -> m Temporary) -> IO Temporary -> m Temporary
forall a b. (a -> b) -> a -> b
$ (Temporary -> FilePath -> IO Temporary)
-> Temporary -> [FilePath] -> IO Temporary
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Temporary -> FilePath -> IO Temporary
runPreprocessor (FilePath -> Temporary
Source FilePath
file0) ((Flags -> [FilePath]) -> Options -> [FilePath]
forall a. (Flags -> a) -> Options -> a
flag Flags -> [FilePath]
optPreprocessors Options
opts)
ByteString
raw <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Temporary -> IO ByteString
keepTemp Temporary
tmp
(Maybe FilePath
optCoding,Either (Posn, FilePath) (ModuleName, ModuleInfo)
parsed) <- Options
-> P (ModuleName, ModuleInfo)
-> ByteString
-> m (Maybe FilePath,
Either (Posn, FilePath) (ModuleName, ModuleInfo))
forall (m :: * -> *) a.
(ErrorMonad m, MonadIO m) =>
Options
-> P a
-> ByteString
-> m (Maybe FilePath, Either (Posn, FilePath) a)
parseSource Options
opts P (ModuleName, ModuleInfo)
pModDef ByteString
raw
case Either (Posn, FilePath) (ModuleName, ModuleInfo)
parsed of
Left (Pn Int
l Int
c,FilePath
msg) -> do FilePath
file <- 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
$ Temporary -> IO FilePath
writeTemp Temporary
tmp
FilePath
cwd <- m FilePath
forall (io :: * -> *). MonadIO io => io FilePath
getCurrentDirectory
let location :: FilePath
location = FilePath -> FilePath -> FilePath
makeRelative FilePath
cwd FilePath
fileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
FilePath -> m (ModuleName, ModuleInfo)
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (FilePath
locationFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":\n "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
msg)
Right (ModuleName
i,ModuleInfo
mi0) ->
do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Temporary -> IO ()
forall (m :: * -> *). MonadIO m => Temporary -> m ()
removeTemp Temporary
tmp
let mi :: ModuleInfo
mi =ModuleInfo
mi0 {mflags :: Options
mflags=ModuleInfo -> Options
mflags ModuleInfo
mi0 Options -> Options -> Options
`addOptions` Options
opts, msrc :: FilePath
msrc=FilePath
file0}
optCoding' :: Maybe FilePath
optCoding' = FilePath -> FilePath
renameEncoding (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Flags -> Maybe FilePath) -> Options -> Maybe FilePath
forall a. (Flags -> a) -> Options -> a
flag Flags -> Maybe FilePath
optEncoding (ModuleInfo -> Options
mflags ModuleInfo
mi0)
case (Maybe FilePath
optCoding,Maybe FilePath
optCoding') of
(Maybe FilePath
_,Just FilePath
coding') ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
codingFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/=FilePath
coding') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> m ()
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Encoding mismatch: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
codingFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" /= "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
coding'
where coding :: FilePath
coding = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
defaultEncoding FilePath -> FilePath
renameEncoding Maybe FilePath
optCoding
(Maybe FilePath, Maybe FilePath)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(ModuleName, ModuleInfo) -> m (ModuleName, ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
i,ModuleInfo
mi)
getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
getBNFCRules Options
opts FilePath
fpath = do
ByteString
raw <- IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
BS.readFile FilePath
fpath)
(Maybe FilePath
optCoding,Either (Posn, FilePath) [BNFCRule]
parsed) <- Options
-> P [BNFCRule]
-> ByteString
-> IO (Maybe FilePath, Either (Posn, FilePath) [BNFCRule])
forall (m :: * -> *) a.
(ErrorMonad m, MonadIO m) =>
Options
-> P a
-> ByteString
-> m (Maybe FilePath, Either (Posn, FilePath) a)
parseSource Options
opts P [BNFCRule]
pBNFCRules ByteString
raw
case Either (Posn, FilePath) [BNFCRule]
parsed of
Left (Posn, FilePath)
_ -> do
let ifToChange :: ByteString -> ByteString -> ByteString
ifToChange ByteString
s ByteString
ss = if ((Char -> Bool) -> ByteString -> Bool
BS.all (\Char
c -> Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c [Char
' ',Char
'\t']) ByteString
s Bool -> Bool -> Bool
|| ByteString -> Char
BS.last ByteString
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') then ByteString
s else ByteString
ss
let raws :: ByteString
raws = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
s -> ByteString -> ByteString -> ByteString
ifToChange ByteString
s (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString
s,Char -> ByteString
BS.singleton Char
';']) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BS.split Char
'\n' ByteString
raw
(Maybe FilePath
optCoding,Either (Posn, FilePath) [BNFCRule]
parseds) <- Options
-> P [BNFCRule]
-> ByteString
-> IO (Maybe FilePath, Either (Posn, FilePath) [BNFCRule])
forall (m :: * -> *) a.
(ErrorMonad m, MonadIO m) =>
Options
-> P a
-> ByteString
-> m (Maybe FilePath, Either (Posn, FilePath) a)
parseSource Options
opts P [BNFCRule]
pBNFCRules ByteString
raws
case Either (Posn, FilePath) [BNFCRule]
parseds of
Left (Pn Int
l Int
c,FilePath
msg) -> do FilePath
cwd <- IO FilePath
forall (io :: * -> *). MonadIO io => io FilePath
getCurrentDirectory
let location :: FilePath
location = FilePath -> FilePath -> FilePath
makeRelative FilePath
cwd FilePath
fpathFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
FilePath -> IOE [BNFCRule]
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (FilePath
locationFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":\n "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
msg)
Right [BNFCRule]
rules -> [BNFCRule] -> IOE [BNFCRule]
forall (m :: * -> *) a. Monad m => a -> m a
return [BNFCRule]
rules
Right [BNFCRule]
rules -> [BNFCRule] -> IOE [BNFCRule]
forall (m :: * -> *) a. Monad m => a -> m a
return [BNFCRule]
rules
getEBNFRules :: Options -> FilePath -> IOE [ERule]
getEBNFRules :: Options -> FilePath -> IOE [ERule]
getEBNFRules Options
opts FilePath
fpath = do
ByteString
raw <- IO ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
BS.readFile FilePath
fpath)
(Maybe FilePath
optCoding,Either (Posn, FilePath) [ERule]
parsed) <- Options
-> P [ERule]
-> ByteString
-> IO (Maybe FilePath, Either (Posn, FilePath) [ERule])
forall (m :: * -> *) a.
(ErrorMonad m, MonadIO m) =>
Options
-> P a
-> ByteString
-> m (Maybe FilePath, Either (Posn, FilePath) a)
parseSource Options
opts P [ERule]
pEBNFRules ByteString
raw
case Either (Posn, FilePath) [ERule]
parsed of
Left (Pn Int
l Int
c,FilePath
msg) -> do FilePath
cwd <- IO FilePath
forall (io :: * -> *). MonadIO io => io FilePath
getCurrentDirectory
let location :: FilePath
location = FilePath -> FilePath -> FilePath
makeRelative FilePath
cwd FilePath
fpathFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
FilePath -> IOE [ERule]
forall (m :: * -> *) a. ErrorMonad m => FilePath -> m a
raise (FilePath
locationFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
":\n "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
msg)
Right [ERule]
rules -> [ERule] -> IOE [ERule]
forall (m :: * -> *) a. Monad m => a -> m a
return [ERule]
rules
runPreprocessor :: Temporary -> String -> IO Temporary
runPreprocessor :: Temporary -> FilePath -> IO Temporary
runPreprocessor Temporary
tmp0 FilePath
p =
IO Temporary
-> ((ByteString -> ByteString) -> IO Temporary)
-> Maybe (ByteString -> ByteString)
-> IO Temporary
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Temporary
external (ByteString -> ByteString) -> IO Temporary
internal (FilePath
-> [(FilePath, ByteString -> ByteString)]
-> Maybe (ByteString -> ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
p [(FilePath, ByteString -> ByteString)]
builtin_preprocessors)
where
internal :: (ByteString -> ByteString) -> IO Temporary
internal ByteString -> ByteString
preproc = (ByteString -> Temporary
Internal (ByteString -> Temporary)
-> (ByteString -> ByteString) -> ByteString -> Temporary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
preproc) (ByteString -> Temporary) -> IO ByteString -> IO Temporary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Temporary -> IO ByteString
readTemp Temporary
tmp0
external :: IO Temporary
external =
do FilePath
file0 <- Temporary -> IO FilePath
writeTemp Temporary
tmp0
let file1a :: FilePath
file1a = FilePath
"_gf_preproc.tmp"
file1b :: FilePath
file1b = FilePath
"_gf_preproc2.tmp"
file1 :: FilePath
file1 = if FilePath
file0FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
file1a then FilePath
file1b else FilePath
file1a
cmd :: FilePath
cmd = FilePath
p FilePath -> FilePath -> FilePath
+++ FilePath
file0 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
">" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file1
FilePath -> IO ExitCode
system FilePath
cmd
Temporary -> IO Temporary
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Temporary
Temp FilePath
file1)
builtin_preprocessors :: [(FilePath, ByteString -> ByteString)]
builtin_preprocessors = [(FilePath
"mkPresent",ByteString -> ByteString
mkPresent),(FilePath
"mkMinimal",ByteString -> ByteString
mkMinimal)]
mkPresent :: ByteString -> ByteString
mkPresent = FilePath -> ByteString -> ByteString
omit_lines FilePath
"--# notpresent"
mkMinimal :: ByteString -> ByteString
mkMinimal = FilePath -> ByteString -> ByteString
omit_lines FilePath
"--# notminimal"
omit_lines :: FilePath -> ByteString -> ByteString
omit_lines FilePath
s = [ByteString] -> ByteString
BS.unlines ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Bool
BS.isInfixOf ByteString
bs) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines
where bs :: ByteString
bs = FilePath -> ByteString
BS.pack FilePath
s
data Temporary = Source FilePath | Temp FilePath | Internal BS.ByteString
writeTemp :: Temporary -> IO FilePath
writeTemp Temporary
tmp =
case Temporary
tmp of
Source FilePath
path -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
Temp FilePath
path -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
Internal ByteString
str -> do
let tmp :: FilePath
tmp = FilePath
"_gf_preproc.tmp"
FilePath -> ByteString -> IO ()
BS.writeFile FilePath
tmp ByteString
str
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmp
readTemp :: Temporary -> IO ByteString
readTemp Temporary
tmp = do ByteString
str <- Temporary -> IO ByteString
keepTemp Temporary
tmp
Temporary -> IO ()
forall (m :: * -> *). MonadIO m => Temporary -> m ()
removeTemp Temporary
tmp
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
str
keepTemp :: Temporary -> IO ByteString
keepTemp Temporary
tmp =
case Temporary
tmp of
Source FilePath
path -> FilePath -> IO ByteString
BS.readFile FilePath
path
Temp FilePath
path -> FilePath -> IO ByteString
BS.readFile FilePath
path
Internal ByteString
str -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
str
removeTemp :: Temporary -> m ()
removeTemp (Temp FilePath
path) = FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
removeFile FilePath
path
removeTemp Temporary
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()