----------------------------------------------------------------------
-- |
-- Module      : GetGrammar
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 17:56:13 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- this module builds the internal GF grammar that is sent to the type checker
-----------------------------------------------------------------------------

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 -> IOE SourceModule
-- | Read a source file and parse it (after applying preprocessors specified in the options)
getSourceModule :: Options -> FilePath -> m (ModuleName, ModuleInfo)
getSourceModule Options
opts FilePath
file0 = 
--errIn 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
   --ePutStrLn $ "1 "++file0
     (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
              {-
              (Nothing,Nothing) ->
                  unless (BS.all isAscii raw) $
                    ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
              -}
              (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 ()
          --liftIO $ transcodeModule' (i,mi) -- old lexer
            (ModuleName, ModuleInfo) -> m (ModuleName, ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
i,ModuleInfo
mi) -- new lexer

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)
---- debug  BS.putStrLn $ raws
  (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  -- change if not all space or end with ';'
      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   -- add semicolon to each line to be able to parse the format in GF book
      (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
         -- FIXME: should use System.IO.openTempFile
         let file1a :: FilePath
file1a = FilePath
"_gf_preproc.tmp"
             file1b :: FilePath
file1b = FilePath
"_gf_preproc2.tmp"
             -- file0 and file1 must be different
             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"   -- grep -v "\-\-\# notpresent"
mkMinimal :: ByteString -> ByteString
mkMinimal = FilePath -> ByteString -> ByteString
omit_lines FilePath
"--# notminimal"   -- grep -v "\-\-\# 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 -- FIXME: should use System.IO.openTempFile
                         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 ()