gf-core/src/compiler/GF/Compile/GetGrammar.hs

----------------------------------------------------------------------
-- |
-- 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 opts file0 = 
--errIn file0 $
  do tmp <- liftIO $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
     raw <- liftIO $ keepTemp tmp
   --ePutStrLn $ "1 "++file0
     (optCoding,parsed) <- parseSource opts pModDef raw
     let indentLines = unlines . map ("   "++) . lines
     case parsed of
       Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
                               cwd <- getCurrentDirectory
                               let location = makeRelative cwd file++":"++show l++":"++show c
                               raise (location++":\n" ++ indentLines msg)
       Right (i,mi0) ->
         do liftIO $ removeTemp tmp
            let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
                optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
            case (optCoding,optCoding') of
              {-
              (Nothing,Nothing) ->
                  unless (BS.all isAscii raw) $
                    ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
              -}
              (_,Just coding') -> 
                  when (coding/=coding') $
                  raise $ "Encoding mismatch: "++coding++" /= "++coding'
                where coding = maybe defaultEncoding renameEncoding optCoding
              _ -> return ()
          --liftIO $ transcodeModule' (i,mi) -- old lexer
            return (i,mi) -- new lexer

getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
getBNFCRules opts fpath = do
  raw <- liftIO (BS.readFile fpath)
---- debug  BS.putStrLn $ raws
  (optCoding,parsed) <- parseSource opts pBNFCRules raw
  case parsed of
    Left _ -> do
      let ifToChange s ss = if (BS.all (\c -> elem c [' ','\t']) s || BS.last s == ';')  then s else ss  -- change if not all space or end with ';'
      let raws = BS.concat $ map (\s -> ifToChange s $ BS.concat [s,BS.singleton ';']) $ BS.split '\n' raw   -- add semicolon to each line to be able to parse the format in GF book
      (optCoding,parseds) <- parseSource opts pBNFCRules raws
      case parseds of
        Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
                                let location = makeRelative cwd fpath++":"++show l++":"++show c
                                raise (location++":\n   "++msg)
        Right rules       -> return rules
    Right rules       -> return rules

getEBNFRules :: Options -> FilePath -> IOE [ERule]
getEBNFRules opts fpath = do
  raw <- liftIO (BS.readFile fpath)
  (optCoding,parsed) <- parseSource opts pEBNFRules raw
  case parsed of
    Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
                            let location = makeRelative cwd fpath++":"++show l++":"++show c
                            raise (location++":\n   "++msg)
    Right rules       -> return rules

runPreprocessor :: Temporary -> String -> IO Temporary
runPreprocessor tmp0 p =
    maybe external internal (lookup p builtin_preprocessors)
  where
    internal preproc = (Internal . preproc) `fmap` readTemp tmp0
    external =
      do file0 <- writeTemp tmp0
         -- FIXME: should use System.IO.openTempFile
         let file1a = "_gf_preproc.tmp"
             file1b = "_gf_preproc2.tmp"
             -- file0 and file1 must be different
             file1 = if file0==file1a then file1b else file1a
             cmd = p +++ file0 ++ ">" ++ file1
         system cmd
         return (Temp file1)

--------------------------------------------------------------------------------

builtin_preprocessors = [("mkPresent",mkPresent),("mkMinimal",mkMinimal)]

mkPresent = omit_lines "--# notpresent"   -- grep -v "\-\-\# notpresent"
mkMinimal = omit_lines "--# notminimal"   -- grep -v "\-\-\# notminimal"

omit_lines s = BS.unlines . filter (not . BS.isInfixOf bs) . BS.lines
  where bs = BS.pack s

--------------------------------------------------------------------------------

data Temporary = Source FilePath | Temp FilePath | Internal BS.ByteString

writeTemp tmp =
    case tmp of
      Source path  -> return path
      Temp   path  -> return path
      Internal str -> do -- FIXME: should use System.IO.openTempFile
                         let tmp = "_gf_preproc.tmp"
                         BS.writeFile tmp str
                         return tmp

readTemp tmp = do str <- keepTemp tmp
                  removeTemp tmp
                  return str

keepTemp tmp =
    case tmp of
      Source path  -> BS.readFile path
      Temp   path  -> BS.readFile path
      Internal str -> return str

removeTemp (Temp path) = removeFile path
removeTemp _           = return ()