forked from GitHub/gf-core
75 lines
2.3 KiB
Haskell
75 lines
2.3 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, ScopedTypeVariables #-}
|
|
-------------------------------------------------
|
|
-- |
|
|
-- Module : PGF2
|
|
-- Maintainer : Krasimir Angelov
|
|
-- Stability : stable
|
|
-- Portability : portable
|
|
--
|
|
-- This module is an Application Programming Interface to
|
|
-- load and interpret grammars compiled in the Portable Grammar Format (PGF).
|
|
-- The PGF format is produced as the final output from the GF compiler.
|
|
-- The API is meant to be used for embedding GF grammars in Haskell
|
|
-- programs
|
|
-------------------------------------------------
|
|
|
|
module PGF2 (-- * PGF
|
|
PGF,readPGF,
|
|
|
|
-- * Abstract syntax
|
|
AbsName,abstractName,
|
|
|
|
-- * Concrete syntax
|
|
ConcName
|
|
) where
|
|
|
|
import Control.Exception(Exception,throwIO,mask_,bracket)
|
|
import System.IO.Unsafe(unsafePerformIO)
|
|
import PGF2.FFI
|
|
|
|
import Foreign
|
|
import Foreign.C
|
|
import Data.Typeable
|
|
import qualified Data.Map as Map
|
|
|
|
#include <pgf.h>
|
|
|
|
type AbsName = String -- ^ Name of abstract syntax
|
|
type ConcName = String -- ^ Name of concrete syntax
|
|
|
|
readPGF :: FilePath -> IO PGF
|
|
readPGF fpath =
|
|
withCString fpath $ \c_fpath ->
|
|
allocaBytes (#size PgfExn) $ \c_exn ->
|
|
mask_ $ do
|
|
c_pgf <- pgf_read c_fpath c_exn
|
|
ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
|
|
if ex_type == (#const PGF_EXN_NONE)
|
|
then do fptr <- newForeignPtr pgf_free_fptr c_pgf
|
|
return (PGF fptr Map.empty)
|
|
else if ex_type == (#const PGF_EXN_SYSTEM_ERROR)
|
|
then do errno <- (#peek PgfExn, code) c_exn
|
|
ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath))
|
|
else do c_msg <- (#peek PgfExn, msg) c_exn
|
|
msg <- peekCString c_msg
|
|
free c_msg
|
|
throwIO (PGFError msg)
|
|
|
|
-- | The abstract language name is the name of the top-level
|
|
-- abstract module
|
|
abstractName :: PGF -> AbsName
|
|
abstractName p =
|
|
unsafePerformIO $
|
|
withForeignPtr (a_pgf p) $ \c_pgf ->
|
|
bracket (pgf_abstract_name c_pgf) free $ \c_text ->
|
|
peekText c_text
|
|
|
|
-----------------------------------------------------------------------
|
|
-- Exceptions
|
|
|
|
newtype PGFError = PGFError String
|
|
deriving (Show, Typeable)
|
|
|
|
instance Exception PGFError
|
|
|