{-# LINE 1 "PGF2/Expr.hsc" #-}


module PGF2.Expr where

import System.IO.Unsafe(unsafePerformIO)
import Foreign hiding (unsafePerformIO)
import Foreign.C
import Data.IORef
import Data.Data
import PGF2.FFI
import Data.Maybe(fromJust)

-- | An data type that represents
-- identifiers for functions and categories in PGF.
type CId = String

wildCId = "_" :: CId

type Cat = CId -- ^ Name of syntactic category
type Fun = CId -- ^ Name of function

data BindType =
    Explicit
  | Implicit
  deriving Show

-----------------------------------------------------------------------------
-- Expressions

-- The C structure for the expression may point to other structures
-- which are allocated from other pools. In order to ensure that
-- they are not released prematurely we use the exprMaster to
-- store references to other Haskell objects

data Expr = Expr {expr :: PgfExpr, touchExpr :: Touch}

instance Show Expr where
  show = showExpr []

instance Eq Expr where
  (Expr e1 e1_touch) == (Expr e2 e2_touch) =
    unsafePerformIO $ do
      res <- pgf_expr_eq e1 e2
      e1_touch >> e2_touch
      return (res /= 0)

instance Data Expr where
  gfoldl f z e   = z (fromJust . readExpr) `f` (showExpr [] e)
  toConstr _     = readExprConstr
  gunfold k z c  = case constrIndex c of
    1 -> k (z (fromJust . readExpr))
    _ -> error "gunfold"
  dataTypeOf _   = exprDataType

readExprConstr :: Constr
readExprConstr = mkConstr exprDataType "(fromJust . readExpr)" [] Prefix

exprDataType :: DataType
exprDataType = mkDataType "PGF2.Expr" [readExprConstr]

-- | Constructs an expression by lambda abstraction
mkAbs :: BindType -> CId -> Expr -> Expr
mkAbs bind_type var (Expr body bodyTouch) =
  unsafePerformIO $ do
      exprPl <- gu_new_pool
      cvar <- newUtf8CString var exprPl
      c_expr <- pgf_expr_abs cbind_type cvar body exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
  where
    cbind_type =
      case bind_type of
        Explicit -> (0)
{-# LINE 74 "PGF2/Expr.hsc" #-}
        Implicit -> (1)
{-# LINE 75 "PGF2/Expr.hsc" #-}

-- | Decomposes an expression into an abstraction and a body
unAbs :: Expr -> Maybe (BindType, CId, Expr)
unAbs (Expr expr touch) =
  unsafePerformIO $ do
      c_abs <- pgf_expr_unabs expr
      if c_abs == nullPtr
        then return Nothing
        else do bt  <- fmap toBindType (((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_abs)
{-# LINE 84 "PGF2/Expr.hsc" #-}
                var <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) c_abs >>= peekUtf8CString
{-# LINE 85 "PGF2/Expr.hsc" #-}
                c_body <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) c_abs
{-# LINE 86 "PGF2/Expr.hsc" #-}
                return (Just (bt, var, Expr c_body touch))
  where
    toBindType :: CInt -> BindType
    toBindType (0) = Explicit
{-# LINE 90 "PGF2/Expr.hsc" #-}
    toBindType (1) = Implicit
{-# LINE 91 "PGF2/Expr.hsc" #-}

-- | Constructs an expression by applying a function to a list of expressions
mkApp :: Fun -> [Expr] -> Expr
mkApp fun args =
  unsafePerformIO $
    withCString fun $ \cfun ->
    allocaBytes (((16)) + len * sizeOf (undefined :: PgfExpr)) $ \papp -> do
{-# LINE 98 "PGF2/Expr.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) papp cfun
{-# LINE 99 "PGF2/Expr.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) papp len
{-# LINE 100 "PGF2/Expr.hsc" #-}
      pokeArray (papp `plusPtr` ((16))) (map expr args)
{-# LINE 101 "PGF2/Expr.hsc" #-}
      exprPl <- gu_new_pool
      c_expr <- pgf_expr_apply papp exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl))
  where
    len = length args

-- | Decomposes an expression into an application of a function
unApp :: Expr -> Maybe (Fun,[Expr])
unApp (Expr expr touch) =
  unsafePerformIO $
    withGuPool $ \pl -> do
      appl <- pgf_expr_unapply expr pl
      if appl == nullPtr
        then return Nothing
        else do
           fun <- peekCString =<< ((\hsc_ptr -> peekByteOff hsc_ptr 0)) appl
{-# LINE 118 "PGF2/Expr.hsc" #-}
           arity <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) appl :: IO CInt
{-# LINE 119 "PGF2/Expr.hsc" #-}
           c_args <- peekArray (fromIntegral arity) (appl `plusPtr` ((16)))
{-# LINE 120 "PGF2/Expr.hsc" #-}
           return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])

-- | Constructs an expression from a string literal
mkStr :: String -> Expr
mkStr str =
  unsafePerformIO $
    withCString str $ \cstr -> do
      exprPl <- gu_new_pool
      c_expr <- pgf_expr_string cstr exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (touchForeignPtr exprFPl))

-- | Decomposes an expression into a string literal
unStr :: Expr -> Maybe String
unStr (Expr expr touch) =
  unsafePerformIO $ do
    plit <- pgf_expr_unlit expr (0)
{-# LINE 137 "PGF2/Expr.hsc" #-}
    if plit == nullPtr
      then return Nothing
      else do s <- peekUtf8CString (plit `plusPtr` ((0)))
{-# LINE 140 "PGF2/Expr.hsc" #-}
              touch
              return (Just s)

-- | Constructs an expression from an integer literal
mkInt :: Int -> Expr
mkInt val =
  unsafePerformIO $ do
      exprPl <- gu_new_pool
      c_expr <- pgf_expr_int (fromIntegral val) exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (touchForeignPtr exprFPl))

-- | Decomposes an expression into an integer literal
unInt :: Expr -> Maybe Int
unInt (Expr expr touch) =
  unsafePerformIO $ do
    plit <- pgf_expr_unlit expr (1)
{-# LINE 157 "PGF2/Expr.hsc" #-}
    if plit == nullPtr
      then return Nothing
      else do n <- peek (plit `plusPtr` ((0)))
{-# LINE 160 "PGF2/Expr.hsc" #-}
              touch
              return (Just (fromIntegral (n :: CInt)))

-- | Constructs an expression from a real number
mkFloat :: Double -> Expr
mkFloat val =
  unsafePerformIO $ do
      exprPl <- gu_new_pool
      c_expr <- pgf_expr_float (realToFrac val) exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (touchForeignPtr exprFPl))

-- | Decomposes an expression into a real number literal
unFloat :: Expr -> Maybe Double
unFloat (Expr expr touch) =
  unsafePerformIO $ do
    plit <- pgf_expr_unlit expr (2)
{-# LINE 177 "PGF2/Expr.hsc" #-}
    if plit == nullPtr
      then return Nothing
      else do n <- peek (plit `plusPtr` ((0)))
{-# LINE 180 "PGF2/Expr.hsc" #-}
              touch
              return (Just (realToFrac (n :: CDouble)))

-- | Constructs a meta variable as an expression
mkMeta :: Int -> Expr
mkMeta id =
  unsafePerformIO $ do
      exprPl <- gu_new_pool
      c_expr <- pgf_expr_meta (fromIntegral id) exprPl
      exprFPl <- newForeignPtr gu_pool_finalizer exprPl
      return (Expr c_expr (touchForeignPtr exprFPl))

-- | Decomposes an expression into a meta variable
unMeta :: Expr -> Maybe Int
unMeta (Expr expr touch) =
  unsafePerformIO $ do
      c_meta <- pgf_expr_unmeta expr
      if c_meta == nullPtr
        then return Nothing
        else do id <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) c_meta
{-# LINE 200 "PGF2/Expr.hsc" #-}
                touch
                return (Just (fromIntegral (id :: CInt)))

-- | this functions is only for backward compatibility with the old Haskell runtime
mkCId x = x

-- | parses a 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr str =
  unsafePerformIO $
    do exprPl <- gu_new_pool
       withGuPool $ \tmpPl ->
         do c_str <- newUtf8CString str tmpPl
            guin <- gu_string_in c_str tmpPl
            exn <- gu_new_exn tmpPl
            c_expr <- pgf_read_expr guin exprPl tmpPl exn
            status <- gu_exn_is_raised exn
            if (not status && c_expr /= nullPtr)
              then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
                      return $ Just (Expr c_expr (touchForeignPtr exprFPl))
              else do gu_pool_free exprPl
                      return Nothing

pExpr :: ReadS Expr
pExpr str =
  unsafePerformIO $
    do exprPl <- gu_new_pool
       withGuPool $ \tmpPl ->
         do ref <- newIORef (str,str,str)
            exn <- gu_new_exn tmpPl
            c_fetch_char <- wrapParserGetc (fetch_char ref)
            c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn
            c_expr <- pgf_expr_parser_expr c_parser 1
            status <- gu_exn_is_raised exn
            if (not status && c_expr /= nullPtr)
              then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
                      (str,_,_) <- readIORef ref
                      return [(Expr c_expr (touchForeignPtr exprFPl),str)]
              else do gu_pool_free exprPl
                      return []
  where
    fetch_char :: IORef (String,String,String) -> Ptr () -> (Word8) -> Ptr GuExn -> IO (Int32)
{-# LINE 242 "PGF2/Expr.hsc" #-}
    fetch_char ref _ mark exn = do
      (str1,str2,str3) <- readIORef ref
      let str1' = if mark /= 0
                    then str2
                    else str1
      case str3 of
        []     -> do writeIORef ref (str1',str3,[])
                     gu_exn_raise exn gu_exn_type_GuEOF
                     return (-1)
        (c:cs) -> do writeIORef ref (str1',str3,cs)
                     return ((fromIntegral . fromEnum) c)

foreign import ccall "pgf/expr.h pgf_new_parser"
  pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser)

foreign import ccall "pgf/expr.h pgf_expr_parser_expr"
  pgf_expr_parser_expr :: Ptr PgfExprParser -> (Word8) -> IO PgfExpr
{-# LINE 259 "PGF2/Expr.hsc" #-}

type ParserGetc = Ptr () -> (Word8) -> Ptr GuExn -> IO (Int32)
{-# LINE 261 "PGF2/Expr.hsc" #-}

foreign import ccall "wrapper"
  wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc)

-- | renders an expression as a 'String'. The list
-- of identifiers is the list of all free variables
-- in the expression in order reverse to the order
-- of binding.
showExpr :: [CId] -> Expr -> String
showExpr scope e =
  unsafePerformIO $
    withGuPool $ \tmpPl ->
      do (sb,out) <- newOut tmpPl
         printCtxt <- newPrintCtxt scope tmpPl
         exn <- gu_new_exn tmpPl
         pgf_print_expr (expr e) printCtxt 1 out exn
         touchExpr e
         s <- gu_string_buf_freeze sb tmpPl
         peekUtf8CString s

newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
newPrintCtxt []     pool = return nullPtr
newPrintCtxt (x:xs) pool = do
  pctxt <- gu_malloc pool ((16))
{-# LINE 285 "PGF2/Expr.hsc" #-}
  newUtf8CString x  pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) pctxt
{-# LINE 286 "PGF2/Expr.hsc" #-}
  newPrintCtxt   xs pool >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) pctxt
{-# LINE 287 "PGF2/Expr.hsc" #-}
  return pctxt