GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-21 18:59:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

pretty printing for expressions and types

Browse Source
This commit is contained in:
krangelov
2021-08-26 15:46:16 +02:00
parent 07bda06fb2
commit 275addfcbe
11 changed files with 572 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

44
src/runtime/haskell/PGF2.hsc
View File

@@ -24,7 +24,7 @@ module PGF2 (-- * PGF
Fun, functions, functionsByCat,
functionType, functionIsConstructor, functionProb,
-- ** Expressions
Expr(..), Literal(..), readExpr,
Expr(..), Literal(..), showExpr, readExpr,
mkAbs, unAbs,
mkApp, unApp, unapply,
mkStr, unStr,
@@ -34,7 +34,7 @@ module PGF2 (-- * PGF
mkMeta, unMeta,
-- ** Types
Type(..), Hypo, BindType(..), startCat,
readType,
readType, showType,
mkType, unType,
mkHypo, mkDepHypo, mkImplHypo,
@@ -277,6 +277,33 @@ functionsByCat p cat =
-----------------------------------------------------------------------
-- Expressions & types
-- | 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 :: [Var] -> Expr -> String
showExpr scope e =
unsafePerformIO $
bracket mkMarshaller freeMarshaller $ \m ->
bracket (newPrintCtxt scope) freePrintCtxt $ \pctxt ->
bracket (newStablePtr e) freeStablePtr $ \c_e ->
bracket (pgf_print_expr c_e pctxt 1 m) free $ \c_text ->
peekText c_text
newPrintCtxt :: [Var] -> IO (Ptr PgfPrintContext)
newPrintCtxt [] = return nullPtr
newPrintCtxt (x:xs) = do
pctxt <- newTextEx (#offset PgfPrintContext, name) x
newPrintCtxt xs >>= (#poke PgfPrintContext, next) pctxt
return pctxt
freePrintCtxt :: Ptr PgfPrintContext -> IO ()
freePrintCtxt pctxt
| pctxt == nullPtr = return ()
| otherwise = do
(#peek PgfPrintContext, next) pctxt >>= freePrintCtxt
free pctxt
-- | parses a 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr str =
@@ -290,6 +317,19 @@ readExpr str =
freeStablePtr c_expr
return (Just expr)
-- | renders a type as a 'String'. The list
-- of identifiers is the list of all free variables
-- in the type in order reverse to the order
-- of binding.
showType :: [Var] -> Type -> String
showType scope ty =
unsafePerformIO $
bracket mkMarshaller freeMarshaller $ \m ->
bracket (newPrintCtxt scope) freePrintCtxt $ \pctxt ->
bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
bracket (pgf_print_type c_ty pctxt 0 m) free $ \c_text ->
peekText c_text
-- | parses a 'String' as a type
readType :: String -> Maybe Type
readType str =

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

@@ -25,6 +25,7 @@ data PgfExn
data PgfText
data PgfItor
data PgfPGF
data PgfPrintContext
data PgfConcr
data PgfTypeHypo
data PgfMarshaller
@@ -51,9 +52,15 @@ foreign import ccall "&pgf_free"
foreign import ccall "pgf_abstract_name"
pgf_abstract_name :: Ptr PgfPGF -> IO (Ptr PgfText)
foreign import ccall "pgf_print_expr"
pgf_print_expr :: StablePtr Expr -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
foreign import ccall "pgf_read_expr"
pgf_read_expr :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Expr)
foreign import ccall "pgf_print_type"
pgf_print_type :: StablePtr Type -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
foreign import ccall "pgf_read_type"
pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
@@ -105,6 +112,16 @@ peekText ptr =
cs <- decode pptr end
return (((toEnum . fromEnum) x) : cs)
newTextEx :: Int -> String -> IO (Ptr a)
newTextEx offs s = do
ptr <- mallocBytes (offs + (#size PgfText) + size + 1)
let ptext = ptr `plusPtr` offs
(#poke PgfText, size) ptext (fromIntegral size :: CSize)
pokeUtf8CString s (ptext `plusPtr` (#const offsetof(PgfText, text)))
return ptr
where
size = utf8Length s
newText :: String -> IO (Ptr PgfText)
newText s = do
ptr <- mallocBytes ((#size PgfText) + size + 1)

44
src/runtime/haskell/tests/basic.hs
View File

@@ -4,10 +4,11 @@ import PGF2
main = do
x <- testLoadFailure "non-existing.pgf"
x <- testLoadFailure "tests/basic.gf"
y <- testLoadFailure "tests/basic.gf"
gr <- readPGF "tests/basic.pgf"
runTestTTAndExit $
TestList [TestCase (assertBool "loading failure handled" x)
TestList [TestCase (assertBool "missing file" x)
,TestCase (assertBool "frong file format" y)
,TestCase (assertEqual "abstract names" "basic" (abstractName gr))
,TestCase (assertEqual "abstract categories" ["Float","Int","N","P","S","String"] (categories gr))
,TestCase (assertEqual "abstract functions" ["c","ind","s","z"] (functions gr))
@@ -18,13 +19,46 @@ main = do
,TestCase (assertBool "type of s" (eqJust (readType "N->N") (functionType gr "s")))
,TestCase (assertBool "type of c" (eqJust (readType "N->S") (functionType gr "c")))
,TestCase (assertEqual "category context 1" [] (categoryContext gr "N"))
,TestCase (assertEqual "category context 1" [] (categoryContext gr "S"))
,TestCase (assertEqual "category context 1" [(Explicit,"_",DTyp [] "N" [])] (categoryContext gr "P"))
,TestCase (assertEqual "category context 1" [] (categoryContext gr "X")) -- no such category
,TestCase (assertEqual "category context 2" [] (categoryContext gr "S"))
,TestCase (assertEqual "category context 3" [(Explicit,"_",DTyp [] "N" [])] (categoryContext gr "P"))
,TestCase (assertEqual "category context 4" [] (categoryContext gr "X")) -- no such category
,TestCase (assertEqual "function is constructor 1" True (functionIsConstructor gr "s"))
,TestCase (assertEqual "function is constructor 2" True (functionIsConstructor gr "z"))
,TestCase (assertEqual "function is constructor 3" True (functionIsConstructor gr "c"))
,TestCase (assertEqual "function is constructor 4" False (functionIsConstructor gr "ind"))
,TestCase (assertEqual "show expression 1" "f x y" (showExpr [] (EApp (EApp (EFun "f") (EFun "x")) (EFun "y"))))
,TestCase (assertEqual "show expression 2" "f (g x)" (showExpr [] (EApp (EFun "f") (EApp (EFun "g") (EFun "x")))))
,TestCase (assertEqual "show expression 3" "f {g x}" (showExpr [] (EApp (EFun "f") (EImplArg (EApp (EFun "g") (EFun "x"))))))
,TestCase (assertEqual "show expression 4" "x" (showExpr ["x"] (EVar 0)))
,TestCase (assertEqual "show expression 5" "#1" (showExpr ["x"] (EVar 1)))
,TestCase (assertEqual "show expression 6" "z" (showExpr ["z","y","x"] (EVar 0)))
,TestCase (assertEqual "show expression 7" "y" (showExpr ["z","y","x"] (EVar 1)))
,TestCase (assertEqual "show expression 8" "\\w->w" (showExpr ["z","y","x"] (EAbs Explicit "w" (EVar 0))))
,TestCase (assertEqual "show expression 9" "\\v,w->z" (showExpr ["z","y","x"] (EAbs Explicit "v" (EAbs Explicit "w" (EVar 2)))))
,TestCase (assertEqual "show expression 10" "\\v,{w}->z" (showExpr ["z","y","x"] (EAbs Explicit "v" (EAbs Implicit "w" (EVar 2)))))
,TestCase (assertEqual "show expression 11" "\\v,{w},z->z" (showExpr ["y","x"] (EAbs Explicit "v" (EAbs Implicit "w" (EAbs Explicit "z" (EVar 0))))))
,TestCase (assertEqual "show expression 12" "\\v,{w,z}->v" (showExpr ["y","x"] (EAbs Explicit "v" (EAbs Implicit "w" (EAbs Implicit "z" (EVar 2))))))
,TestCase (assertEqual "show expression 13" "\\v,{w,z},t->v" (showExpr ["y","x"] (EAbs Explicit "v" (EAbs Implicit "w" (EAbs Implicit "z" (EAbs Explicit "t" (EVar 3)))))))
,TestCase (assertEqual "show expression 14" "\\u,v,{w,z},t->v" (showExpr ["y","x"] (EAbs Explicit "u" (EAbs Explicit "v" (EAbs Implicit "w" (EAbs Implicit "z" (EAbs Explicit "t" (EVar 3))))))))
,TestCase (assertEqual "show expression 15" "f (\\x->x)" (showExpr [] (EApp (EFun "f") (EAbs Explicit "x" (EVar 0)))))
,TestCase (assertEqual "show expression 16" "?" (showExpr [] (EMeta 0)))
,TestCase (assertEqual "show expression 17" "?42" (showExpr [] (EMeta 42)))
,TestCase (assertEqual "show expression 18" "<z : N>" (showExpr [] (ETyped (EFun "z") (DTyp [] "N" []))))
,TestCase (assertEqual "show expression 19" "42" (showExpr [] (ELit (LInt 42))))
,TestCase (assertEqual "show expression 20" "3.14" (showExpr [] (ELit (LFlt 3.14))))
,TestCase (assertEqual "show expression 21" "\"abc\"" (showExpr [] (ELit (LStr "abc"))))
,TestCase (assertEqual "show expression 22" "\"ab\\0c\"" (showExpr [] (ELit (LStr "ab\0c"))))
,TestCase (assertEqual "show expression 23" "\"ab\\nc\"" (showExpr [] (ELit (LStr "ab\nc"))))
,TestCase (assertEqual "show type 1" "N" (showType [] (DTyp [] "N" [])))
,TestCase (assertEqual "show type 2" "N -> N" (showType [] (DTyp [(Explicit,"_",DTyp [] "N" [])] "N" [])))
,TestCase (assertEqual "show type 3" "(N -> N) -> N" (showType [] (DTyp [(Explicit,"_",DTyp [(Explicit,"_",DTyp [] "N" [])] "N" [])] "N" [])))
,TestCase (assertEqual "show type 4" "(x : N) -> P x" (showType [] (DTyp [(Explicit,"x",DTyp [] "N" [])] "P" [EVar 0])))
,TestCase (assertEqual "show type 5" "(f : N -> N) -> P (f z)" (showType [] (DTyp [(Explicit,"f",DTyp [(Explicit,"_",DTyp [] "N" [])] "N" [])] "P" [EApp (EVar 0) (EFun "z")])))
,TestCase (assertEqual "show type 6" "(f : N -> N) -> P (f n)" (showType ["n"] (DTyp [(Explicit,"f",DTyp [(Explicit,"_",DTyp [] "N" [])] "N" [])] "P" [EApp (EVar 0) (EVar 1)])))
,TestCase (assertEqual "show type 7" "({f} : N -> N) -> P (f n)" (showType ["n"] (DTyp [(Implicit,"f",DTyp [(Explicit,"_",DTyp [] "N" [])] "N" [])] "P" [EApp (EVar 0) (EVar 1)])))
,TestCase (assertEqual "fresh variables 1" "\\v,v1->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 0)))))
,TestCase (assertEqual "fresh variables 2" "\\v,v1->v" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1)))))
,TestCase (assertEqual "fresh variables 3" "\\v,v1,v2->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1))))))
]
testLoadFailure fpath = do