GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-07 18:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

correctly distinguish between fun and data judgements

Browse Source
This commit is contained in:
krangelov
2021-11-18 13:50:09 +01:00
parent 7ff38bfcbe
commit 06980404a9
27 changed files with 59 additions and 332 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
src/runtime/haskell/PGF2/Internal.hsc → src/runtime/haskell/PGF2/ByteCode.hs
View File

@@ -1,30 +1,9 @@
{-# LANGUAGE ImplicitParams, RankNTypes #-}
module PGF2.Internal(-- * Access the internal structures
FId,isPredefFId,
fidString,fidInt,fidFloat,fidVar,fidStart,
-- * Byte code
module PGF2.ByteCode(-- * Byte code
CodeLabel, Instr(..), IVal(..), TailInfo(..),
unionPGF, writeConcr
) where
import PGF2.FFI
import PGF2.Expr
type FId = Int
fidString, fidInt, fidFloat, fidVar, fidStart :: FId
fidString = (-1)
fidInt = (-2)
fidFloat = (-3)
fidVar = (-4)
fidStart = (-5)
isPredefFId :: FId -> Bool
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])
type CodeLabel = Int
data Instr
@@ -60,9 +39,3 @@ data TailInfo
= RecCall
| TailCall {-# UNPACK #-} !Int
| UpdateCall
unionPGF :: PGF -> PGF -> Maybe PGF
unionPGF = error "TODO: unionPGF"
writeConcr :: FilePath -> Concr -> IO ()
writeConcr = error "TODO: writeConcr"

2
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -151,7 +151,7 @@ foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -
foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF)
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> Ptr CChar -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()

8
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -28,6 +28,7 @@ module PGF2.Transactions
import PGF2.FFI
import PGF2.Expr
import PGF2.ByteCode
import Foreign
import Foreign.C
@@ -123,12 +124,13 @@ checkoutPGF p name =
langs <- getConcretes (a_db p) fptr
return (Just (PGF (a_db p) fptr langs))
createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF ()
createFunction name ty arity prob = Transaction $ \c_db _ c_revision c_exn ->
createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF ()
createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
withText name $ \c_name ->
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
(if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode ->
withForeignPtr marshaller $ \m -> do
pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn
pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob m c_exn
dropFunction :: Fun -> Transaction PGF ()
dropFunction name = Transaction $ \c_db _ c_revision c_exn ->

2
src/runtime/haskell/pgf2.cabal
View File

@@ -23,7 +23,7 @@ library
exposed-modules:
PGF2,
PGF2.Transactions,
PGF2.Internal,
PGF2.ByteCode,
-- backwards compatibility API:
PGF
other-modules:

BIN
src/runtime/haskell/tests/basic.pgf
View File

Binary file not shown.

19
src/runtime/haskell/tests/basic_cnc.gf Normal file
View File

@@ -0,0 +1,19 @@
concrete basic_cnc of basic = open Prelude in {
lincat N = {s : Str; is_zero : Bool} ;
lincat S = Str ;
lin z = {s="0"; is_zero=True} ;
s n = {
s = case n.is_zero of {
True => "1" ;
False => n.s ++ "+" ++ "1"
} ;
is_zero = False
} ;
lin c n = n.s ;
lincat P = {};
}

8
src/runtime/haskell/tests/transactions.hs
View File

@@ -9,9 +9,9 @@ main = do
gr1 <- readPGF "tests/basic.pgf"
let Just ty = readType "(N -> N) -> P (s z)"
gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 pi >>
gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >>
createCategory "Q" [(Explicit,"x",ty)] pi)
gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 pi >>
gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 [] pi >>
createCategory "R" [(Explicit,"x",ty)] pi)
Just gr4 <- checkoutPGF gr1 "master"
@@ -44,8 +44,8 @@ main = do
,TestCase (assertEqual "new function prob" pi (functionProbability gr2 "foo"))
,TestCase (assertEqual "old category prob" (-log 0) (categoryProbability gr1 "Q"))
,TestCase (assertEqual "new category prob" pi (categoryProbability gr2 "Q"))
,TestCase (assertEqual "empty concretes" [] (Map.keys (languages gr1)))
,TestCase (assertEqual "extended concretes" ["basic_eng"] (Map.keys (languages gr7)))
,TestCase (assertEqual "empty concretes" ["basic_cnc"] (Map.keys (languages gr1)))
,TestCase (assertEqual "extended concretes" ["basic_cnc","basic_eng"] (Map.keys (languages gr7)))
,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc "test_flag"))
]