msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

the compiler now compiles with the new runtime

Browse Source
This commit is contained in:
krangelov
2021-09-13 18:32:57 +02:00
parent c5ce2fd4b7
commit cf7673525f
26 changed files with 765 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Command/Commands.hs
View File

@@ -6,7 +6,6 @@ module GF.Command.Commands (
import Prelude hiding (putStrLn,(<>))
import PGF2
import PGF2.Internal(writePGF)
import GF.Compile.Export
import GF.Compile.ToAPI
@@ -666,7 +665,7 @@ pgfCommands = Map.fromList [
[e] -> case unApp e of
Just (id, []) -> case functionType pgf id of
Just ty -> do putStrLn (showFun pgf id ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
putStrLn ("Probability: "++show (exprProbability pgf e))
return void
Nothing -> case categoryContext pgf id of
Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
@@ -682,7 +681,7 @@ pgfCommands = Map.fromList [
Left err -> error err
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
putStrLn ("Type: "++showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
putStrLn ("Probability: "++show (exprProbability pgf e))
return void
_ -> do putStrLn "a single identifier or expression is expected from the command"
return void,
@@ -800,8 +799,8 @@ pgfCommands = Map.fromList [
showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
where
kwd | functionIsDataCon pgf id = "data"
| otherwise = "fun"
kwd | functionIsConstructor pgf id = "data"
| otherwise = "fun"
morphos pgf opts s =
[(s,lookupMorpho concr s) | concr <- optLangs pgf opts]

3
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -21,7 +21,7 @@ import Data.Maybe(fromMaybe)
--------------------------
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
cf2pgf opts fpath cf probs =
cf2pgf opts fpath cf probs = error "TODO: cf2pgf" {-
build (let abstr = cf2abstr cf probs
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
where
@@ -134,3 +134,4 @@ mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> "_"
-}

24
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -4,7 +4,7 @@ module GF.Compile.Compute.Predef(predef,predefName,delta) where
import qualified Data.Map as Map
import Data.Array(array,(!))
import Data.List (isInfixOf)
import Data.List (isInfixOf,genericTake,genericDrop,genericLength)
import Data.Char (isUpper,toLower,toUpper)
import Control.Monad(ap)
@@ -20,7 +20,7 @@ class Predef a where
toValue :: a -> Value
fromValue :: Value -> Err a
instance Predef Int where
instance Predef Integer where
toValue = VInt
fromValue (VInt i) = return i
fromValue v = verror "Int" v
@@ -87,8 +87,8 @@ predefList =
delta f vs =
case f of
Drop -> fromNonExist vs NonExist (ap2 (drop::Int->String->String))
Take -> fromNonExist vs NonExist (ap2 (take::Int->String->String))
Drop -> fromNonExist vs NonExist (ap2 (genericDrop::Integer->String->String))
Take -> fromNonExist vs NonExist (ap2 (genericTake::Integer->String->String))
Tk -> fromNonExist vs NonExist (ap2 tk)
Dp -> fromNonExist vs NonExist (ap2 dp)
EqStr -> fromNonExist vs PFalse (ap2 ((==)::String->String->Bool))
@@ -97,10 +97,10 @@ delta f vs =
ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper))
ToLower -> fromNonExist vs NonExist (ap1 (map toLower))
IsUpper -> fromNonExist vs PFalse (ap1 (all' isUpper))
Length -> fromNonExist vs (0::Int) (ap1 (length::String->Int))
Plus -> ap2 ((+)::Int->Int->Int)
EqInt -> ap2 ((==)::Int->Int->Bool)
LessInt -> ap2 ((<)::Int->Int->Bool)
Length -> fromNonExist vs (0::Integer) (ap1 (genericLength::String->Integer))
Plus -> ap2 ((+)::Integer->Integer->Integer)
EqInt -> ap2 ((==)::Integer->Integer->Bool)
LessInt -> ap2 ((<)::Integer->Integer->Bool)
{- -- | Show | Read | ToStr | MapStr | EqVal -}
Error -> ap1 VError
Trace -> ap2 vtrace
@@ -139,8 +139,12 @@ delta f vs =
-- unimpl id = bug $ "unimplemented predefined function: "++showIdent id
-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
tk i s = take (max 0 (length s - i)) s :: String
dp i s = drop (max 0 (length s - i)) s :: String
tk :: Integer -> String -> String
tk i s = genericTake (max 0 (genericLength s - i)) s
dp :: Integer -> String -> String
dp i s = genericDrop (max 0 (genericLength s - i)) s
occur s t = isInfixOf (s::String) (t::String)
occurs s t = any (`elem` (t::String)) (s::String)
all' = all :: (a->Bool) -> [a] -> Bool

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -14,7 +14,7 @@ data Value
-- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
| VAbs BindType Ident Binding -- used in Compute.Concrete
| VProd BindType Value Ident Binding -- used in Compute.Concrete
| VInt Int
| VInt Integer
| VFloat Double
| VString String
| VSort Ident

8
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -1,5 +1,7 @@
-- | Translate concrete syntax to Haskell
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
import PGF2(Literal(..))
import Data.List(isPrefixOf,sort,sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -181,9 +183,9 @@ concrete2haskell opts
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
LFlt x -> pure (lit x)
LInt n -> pure (lit n)
LStr s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack

3
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -4,7 +4,8 @@ module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import PGF2(Literal(..))
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)

20
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -19,7 +19,7 @@ import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF)
import PGF2.Internal(Literal(..))
import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
@@ -193,11 +193,11 @@ convert' gr vs = ppT
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant n)
EInt n -> LiteralValue (LInt n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
QC (m,n) -> ParamConstant (Param (gQId m n) [])
K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "")
K s -> LiteralValue (LStr s)
Empty -> LiteralValue (LStr "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' ppT: " ++ show t
@@ -265,8 +265,8 @@ convert' gr vs = ppT
concatValue :: LinValue -> LinValue -> LinValue
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
(LiteralValue (LStr ""),_) -> v2
(_,LiteralValue (LStr "")) -> v1
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
@@ -429,11 +429,5 @@ unqual n = Unqual (ident2raw n)
convFlags :: G.Grammar -> ModuleName -> Flags
convFlags gr mn =
Flags [(rawIdentS n,convLit v) |
Flags [(rawIdentS n,v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where
convLit l =
case l of
LStr s -> Str s
LInt i -> C.Int i
LFlt d -> Flt d

3
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -30,7 +30,7 @@ import GHC.Prim
import GHC.Base(getTag)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
grammar2PGF opts gr am probs = error "TODO: grammar2PGF" {-do
cnc_infos <- getConcreteInfos gr am
return $
build (let gflags = if flag optSplitPGF opts
@@ -445,3 +445,4 @@ compareCaseInsensitive (x:xs) (y:ys) =
EQ -> compare x y
x -> x
x -> x
-}

3
src/compiler/GF/Compile/OptimizePGF.hs
View File

@@ -20,7 +20,7 @@ type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
optimizePGF :: Cat -> ConcrData -> ConcrData
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
catString = "String"
catInt = "Int"
@@ -187,3 +187,4 @@ filterProductions prods0 hoc0 prods
accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
accumHOC hoc _ = hoc
-}

5
src/compiler/GF/Compile/PGFtoJSON.hs
View File

@@ -6,8 +6,8 @@ import Text.JSON
import qualified Data.Map as Map
pgf2json :: PGF -> String
pgf2json pgf =
encode $ makeObj
pgf2json pgf = error "TODO: pgf2json"
{- encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
@@ -108,3 +108,4 @@ new f xs =
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-}

2
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -35,7 +35,7 @@ data AExp =
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Int
| AInt Integer
| AFloat Double
| AStr String
| AMeta MetaId Val

2
src/compiler/GF/Compiler.hs
View File

@@ -1,7 +1,7 @@
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
import PGF2
import PGF2.Internal(unionPGF,writePGF,writeConcr)
import PGF2.Internal(unionPGF,writeConcr)
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export

2
src/compiler/GF/Grammar/BNFC.hs
View File

@@ -25,7 +25,7 @@ data BNFCRule = BNFCRule {
ruleName :: CFTerm }
| BNFCCoercions {
coerCat :: Cat,
coerNum :: Int }
coerNum :: Integer }
| BNFCTerminator {
termNonEmpty :: Bool,
termCat :: Cat,

3
src/compiler/GF/Grammar/Binary.hs
View File

@@ -22,7 +22,8 @@ import GF.Infra.Option
import GF.Infra.UseIO(MonadIO(..))
import GF.Grammar.Grammar
import PGF2.Internal(Literal(..),Symbol(..))
import PGF2(Literal(..))
import PGF2.Internal(Symbol(..))
-- Please change this every time when the GFO format is changed
gfoVersion = "GF04"

27
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -9,9 +9,11 @@
{-# LANGUAGE DeriveTraversable #-}
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
import GF.Infra.Ident (RawIdent)
import PGF(Literal(..))
-- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -58,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-- | Linearization value, RHS of @lin@
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| LiteralValue Literal
| ErrorValue String
| ParamConstant ParamValue
| PredefValue PredefId
@@ -74,11 +76,6 @@ data LinValue = ConcatValue LinValue LinValue
| CommentedValue String LinValue
deriving (Eq,Ord,Show)
data LinLiteral = FloatConstant Float
| IntConstant Int
| StrConstant String
deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern
| RecordPattern [RecordRow LinPattern]
| TuplePattern [LinPattern]
@@ -120,9 +117,8 @@ newtype FunId = FunId Id deriving (Eq,Show)
data VarId = Anonymous | VarId Id deriving Show
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
newtype Flags = Flags [(FlagName,Literal)] deriving Show
type FlagName = Id
data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
@@ -243,13 +239,13 @@ instance PPA LinValue where
VarValue v -> pp v
_ -> parens lv
instance Pretty LinLiteral where pp = ppA
instance Pretty Literal where pp = ppA
instance PPA LinLiteral where
instance PPA Literal where
ppA l = case l of
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
LFlt f -> pp f
LInt n -> pp n
LStr s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "="
@@ -298,11 +294,6 @@ instance Pretty Flags where
where
ppFlag (name,value) = name <+> "=" <+> value <>";"
instance Pretty FlagValue where
pp (Str s) = pp s
pp (Int i) = pp i
pp (Flt d) = pp d
--------------------------------------------------------------------------------
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
class Pretty a => PPA a where ppA :: a -> Doc

21
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -8,7 +8,7 @@ import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
import PGF(Literal(..))
encodeJSON :: FilePath -> Grammar -> IO ()
encodeJSON fpath g = writeFile fpath (encode g)
@@ -171,13 +171,13 @@ instance JSON LinValue where
<|> do vs <- readJSON o :: Result [LinValue]
return (foldr1 ConcatValue vs)
instance JSON LinLiteral where
instance JSON Literal where
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
showJSON (StrConstant s) = showJSON s
showJSON (FloatConstant f) = showJSON f
showJSON (IntConstant n) = showJSON n
showJSON (LStr s) = showJSON s
showJSON (LFlt f) = showJSON f
showJSON (LInt n) = showJSON n
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
readJSON = readBasicJSON LStr LInt LFlt
instance JSON LinPattern where
-- wildcards and patterns without arguments are encoded as strings:
@@ -262,15 +262,6 @@ instance JSON Flags where
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (rawIdentS lbl, value)
instance JSON FlagValue where
-- flag values are encoded as basic JSON types:
showJSON (Str s) = showJSON s
showJSON (Int i) = showJSON i
showJSON (Flt f) = showJSON f
readJSON = readBasicJSON Str Int Flt
--------------------------------------------------------------------------------
-- ** Convenience functions

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -354,7 +354,7 @@ data Term =
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| Sort Ident -- ^ basic type
| EInt Int -- ^ integer literal
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
@@ -409,7 +409,7 @@ data Patt =
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Int -- ^ integer literal pattern: @12@ -- only abstract
| PInt Integer -- ^ integer literal pattern: @12@ -- only abstract
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern

2
src/compiler/GF/Grammar/Lexer.x
View File

@@ -130,7 +130,7 @@ data Token
| T_separator
| T_nonempty
| T_String String -- string literals
| T_Integer Int -- integer literals
| T_Integer Integer -- integer literals
| T_Double Double -- double precision float literals
| T_Ident Ident
| T_EOF

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -216,7 +216,7 @@ typeTok = Sort cTok
typeStrs = Sort cStrs
typeString, typeFloat, typeInt :: Type
typeInts :: Int -> Type
typeInts :: Integer -> Type
typePBool :: Type
typeError :: Type
@@ -227,7 +227,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool
typeError = cnPredef cErrorType
isTypeInts :: Type -> Maybe Int
isTypeInts :: Type -> Maybe Integer
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _ = Nothing
@@ -324,7 +324,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
string2term :: String -> Term
string2term = K
int2term :: Int -> Term
int2term :: Integer -> Term
int2term = EInt
float2term :: Double -> Term

2
src/compiler/GF/Infra/Option.hs
View File

@@ -35,7 +35,7 @@ import GF.Infra.Ident
import GF.Infra.GetOpt
import GF.Grammar.Predef
import System.FilePath
import PGF2.Internal(Literal(..))
import PGF2(Literal(..))
import GF.Data.Operations(Err,ErrorMonad(..),liftErr)

3
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -25,7 +25,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
pgfToCFG :: PGF -> Concr -> CFG
pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
pgfToCFG pgf cnc = error "TODO: pgfToCFG" {- mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
where
(_,start_cat,_) = unType (startCat pgf)
@@ -116,3 +116,4 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
ruleToCFRule (c,PCoerce c') =
[Rule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0)
| l <- [0..catLinArity c-1]]
-}

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

@@ -14,17 +14,20 @@
-------------------------------------------------
module PGF2 (-- * PGF
PGF,readPGF,bootNGF,readNGF,
PGF,readPGF,bootNGF,readNGF,writePGF,showPGF,
-- * Abstract syntax
AbsName,abstractName,globalFlag,abstractFlag,
-- ** Categories
Cat,categories,categoryContext,categoryProb,
Cat,categories,categoryContext,categoryProbability,
-- ** Functions
Fun, functions, functionsByCat,
functionType, functionIsConstructor, functionProb,
functionType, functionIsConstructor, functionProbability,
-- ** Expressions
Expr(..), Literal(..), showExpr, readExpr,
Expr(..), Literal(..), showExpr, readExpr, pExpr, pIdent,
mkAbs, unAbs,
mkApp, unApp, unapply,
mkStr, unStr,
@@ -33,20 +36,58 @@ module PGF2 (-- * PGF
mkFloat, unFloat,
mkMeta, unMeta,
-- extra
exprSize, exprFunctions,
exprSize, exprFunctions, exprSubstitute, exprProbability,
-- ** Types
Type(..), Hypo, BindType(..), startCat,
readType, showType,
readType, showType, showContext,
mkType, unType,
mkHypo, mkDepHypo, mkImplHypo,
-- ** Type checking
-- | Dynamically-built expressions should always be type-checked before using in other functions,
-- as the exceptions thrown by using invalid expressions may not catchable.
checkExpr, inferExpr, checkType,
-- ** Computing
compute,
-- ** Generation
generateAll, generateAllFrom, generateRandom, generateRandomFrom,
-- ** Morphological Analysis
MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
filterBest, filterLongest,
-- ** Visualizations
GraphvizOptions(..), graphvizDefaults,
graphvizAbstractTree, graphvizParseTree,
Labels, getDepLabels,
graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
graphvizWordAlignment,
-- * Concrete syntax
ConcName,
ConcName,Concr,languages,concreteName,languageCode,
-- ** Linearization
linearize, linearizeAll, tabularLinearize, tabularLinearizeAll,
FId, BracketedString(..), showBracketedString, flattenBracketedString,
bracketedLinearize, bracketedLinearizeAll,
hasLinearization,
printName, alignWords, gizaAlignment,
-- ** Parsing
ParseOutput(..), parse, parseWithHeuristics, complete,
-- * Exceptions
PGFError(..)
PGFError(..),
-- * Auxiliaries
readProbabilitiesFromFile
) where
import Prelude hiding ((<>))
import PGF2.Expr
import PGF2.FFI
@@ -54,15 +95,16 @@ import Foreign
import Foreign.C
import Control.Exception(mask_,bracket)
import System.IO.Unsafe(unsafePerformIO)
import System.Random
import qualified Foreign.Concurrent as C
import qualified Data.Map as Map
import Data.IORef
import Data.List(intersperse,groupBy)
import Data.Char(isUpper,isSpace,isPunctuation)
import Text.PrettyPrint
#include <pgf/pgf.h>
type AbsName = String -- ^ Name of abstract syntax
type ConcName = String -- ^ Name of concrete syntax
-- | Reads a PGF file and keeps it in memory.
readPGF :: FilePath -> IO PGF
readPGF fpath =
@@ -106,6 +148,12 @@ readNGF fpath =
fptr2 <- C.newForeignPtr c_revision (withForeignPtr fptr1 (\c_db -> pgf_free_revision c_db c_revision))
return (PGF fptr1 fptr2 Map.empty)
writePGF :: FilePath -> PGF -> IO ()
writePGF = error "TODO: writePGF"
showPGF :: PGF -> String
showPGF = error "TODO: showPGF"
-- | The abstract language name is the name of the top-level
-- abstract module
abstractName :: PGF -> AbsName
@@ -156,14 +204,273 @@ functionIsConstructor p fun =
do res <- withPgfExn (pgf_function_is_constructor c_db c_revision c_fun)
return (res /= 0)
functionProb :: PGF -> Fun -> Float
functionProb p fun =
functionProbability :: PGF -> Fun -> Float
functionProbability p fun =
unsafePerformIO $
withText fun $ \c_fun ->
withForeignPtr (a_db p) $ \c_db ->
withForeignPtr (revision p) $ \c_revision ->
withPgfExn (pgf_function_prob c_db c_revision c_fun)
exprProbability :: PGF -> Expr -> Float
exprProbability = error "TODO: exprProbability"
checkExpr :: PGF -> Expr -> Type -> Either String Expr
checkExpr = error "TODO: checkExpr"
-- | Tries to infer the type of an expression. Note that
-- even if the expression is type correct it is not always
-- possible to infer its type in the GF type system.
-- In this case the function returns an error.
inferExpr :: PGF -> Expr -> Either String (Expr, Type)
inferExpr = error "TODO: inferExpr"
-- | Check whether a type is consistent with the abstract
-- syntax of the grammar.
checkType :: PGF -> Type -> Either String Type
checkType = error "TODO: checkType"
compute :: PGF -> Expr -> Expr
compute = error "TODO: compute"
concreteName :: Concr -> ConcName
concreteName c = error "TODO: concreteName"
languageCode :: Concr -> Maybe String
languageCode c = error "TODO: languageCode"
printName :: Concr -> Fun -> Maybe String
printName lang fun = error "TODO: printName"
alignWords :: Concr -> Expr -> [(String, [Int])]
alignWords = error "TODO: alignWords"
gizaAlignment = error "TODO: gizaAlignment"
-----------------------------------------------------------------------------
-- Functions using Concr
-- Morpho analyses, parsing & linearization
-- | This triple is returned by all functions that deal with
-- the grammar's lexicon. Its first element is the name of an abstract
-- lexical function which can produce a given word or
-- a multiword expression (i.e. this is the lemma).
-- After that follows a string which describes
-- the particular inflection form.
--
-- The last element is a logarithm from the
-- the probability of the function. The probability is not
-- conditionalized on the category of the function. This makes it
-- possible to compare the likelihood of two functions even if they
-- have different types.
type MorphoAnalysis = (Fun,String,Float)
-- | 'lookupMorpho' takes a string which must be a single word or
-- a multiword expression. It then computes the list of all possible
-- morphological analyses.
lookupMorpho :: Concr -> String -> [MorphoAnalysis]
lookupMorpho = error "TODO: lookupMorpho"
-- | 'lookupCohorts' takes an arbitrary string an produces
-- a list of all places where lexical items from the grammar have been
-- identified (i.e. cohorts). The list consists of triples of the format @(start,ans,end)@,
-- where @start-end@ identifies the span in the text and @ans@ is
-- the list of possible morphological analyses similar to 'lookupMorpho'.
--
-- The list is sorted first by the @start@ position and after than
-- by the @end@ position. This can be used for instance if you want to
-- filter only the longest matches.
lookupCohorts :: Concr -> String -> [(Int,String,[MorphoAnalysis],Int)]
lookupCohorts = error "TODO: lookupCohorts"
filterBest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
filterBest ans =
reverse (iterate (maxBound :: Int) [(0,0,[],ans)] [] [])
where
iterate v0 [] [] res = res
iterate v0 [] new res = iterate v0 new [] res
iterate v0 ((_,v,conf, []):old) new res =
case compare v0 v of
LT -> res
EQ -> iterate v0 old new (merge conf res)
GT -> iterate v old new conf
iterate v0 ((_,v,conf,an:ans):old) new res = iterate v0 old (insert (v+valueOf an) conf an ans [] new) res
valueOf (_,_,[],_) = 2
valueOf _ = 1
insert v conf an@(start,_,_,end) ans l_new [] =
match start v conf ans ((end,v,comb conf an,filter end ans):l_new) []
insert v conf an@(start,_,_,end) ans l_new (new@(end0,v0,conf0,ans0):r_new) =
case compare end0 end of
LT -> insert v conf an ans (new:l_new) r_new
EQ -> case compare v0 v of
LT -> match start v conf ans ((end,v, conf0,ans0): l_new) r_new
EQ -> match start v conf ans ((end,v,merge (comb conf an) conf0,ans0): l_new) r_new
GT -> match start v conf ans ((end,v,comb conf an, ans0): l_new) r_new
GT -> match start v conf ans ((end,v,comb conf an, filter end ans):new:l_new) r_new
match start0 v conf (an@(start,_,_,end):ans) l_new r_new
| start0 == start = insert v conf an ans l_new r_new
match start0 v conf ans l_new r_new = revOn l_new r_new
comb ((start0,w0,an0,end0):conf) (start,w,an,end)
| end0 == start && (unk w0 an0 || unk w an) = (start0,w0++w,[],end):conf
comb conf an = an:conf
filter end [] = []
filter end (next@(start,_,_,_):ans)
| end <= start = next:ans
| otherwise = filter end ans
revOn [] ys = ys
revOn (x:xs) ys = revOn xs (x:ys)
merge [] ans = ans
merge ans [] = ans
merge (an1@(start1,_,_,end1):ans1) (an2@(start2,_,_,end2):ans2) =
case compare (start1,end1) (start2,end2) of
GT -> an1 : merge ans1 (an2:ans2)
EQ -> an1 : merge ans1 ans2
LT -> an2 : merge (an1:ans1) ans2
filterLongest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
filterLongest [] = []
filterLongest (an:ans) = longest an ans
where
longest prev [] = [prev]
longest prev@(start0,_,_,end0) (next@(start,_,_,end):ans)
| start0 == start = longest next ans
| otherwise = filter prev (next:ans)
filter prev [] = [prev]
filter prev@(start0,w0,an0,end0) (next@(start,w,an,end):ans)
| end0 == start && (unk w0 an0 || unk w an)
= filter (start0,w0++w,[],end) ans
| end0 <= start = prev : longest next ans
| otherwise = filter prev ans
unk w [] | any (not . isPunctuation) w = True
unk _ _ = False
fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])]
fullFormLexicon lang = error "TODO: fullFormLexicon"
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput a
= ParseFailed Int String -- ^ The integer is the position in number of unicode characters where the parser failed.
-- The string is the token where the parser have failed.
| ParseOk a -- ^ If the parsing and the type checking are successful
-- we get the abstract syntax trees as either a list or a chart.
| ParseIncomplete -- ^ The sentence is not complete.
parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) []
parseWithHeuristics :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence
-> Double -- ^ the heuristic factor.
-- A negative value tells the parser
-- to lookup up the default from
-- the grammar flags
-> [(Cat, String -> Int -> Maybe (Expr,Float,Int))]
-- ^ a list of callbacks for literal categories.
-- The arguments of the callback are:
-- the index of the constituent for the literal category;
-- the input sentence; the current offset in the sentence.
-- If a literal has been recognized then the output should
-- be Just (expr,probability,end_offset)
-> ParseOutput [(Expr,Float)]
parseWithHeuristics = error "TODO: parseWithHeuristics"
-- | Returns possible completions of the current partial input.
complete :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence (excluding token being completed)
-> String -- ^ prefix (partial token being completed)
-> ParseOutput [(String, Fun, Cat, Float)] -- ^ (token, category, function, probability)
complete = error "TODO: complete"
-- | Returns True if there is a linearization defined for that function in that language
hasLinearization :: Concr -> Fun -> Bool
hasLinearization = error "TODO: linearize"
-- | Linearizes an expression as a string in the language
linearize :: Concr -> Expr -> String
linearize lang e = error "TODO: linearize"
-- | Generates all possible linearizations of an expression
linearizeAll :: Concr -> Expr -> [String]
linearizeAll lang e = error "TODO: linearizeAll"
-- | Generates a table of linearizations for an expression
tabularLinearize :: Concr -> Expr -> [(String, String)]
tabularLinearize lang e =
case tabularLinearizeAll lang e of
(lins:_) -> lins
_ -> []
-- | Generates a table of linearizations for an expression
tabularLinearizeAll :: Concr -> Expr -> [[(String, String)]]
tabularLinearizeAll lang e = error "TODO: tabularLinearizeAll"
type FId = Int
-- | BracketedString represents a sentence that is linearized
-- as usual but we also want to retain the ''brackets'' that
-- mark the beginning and the end of each constituent.
data BracketedString
= Leaf String -- ^ this is the leaf i.e. a single token
| BIND -- ^ the surrounding tokens must be bound together
| Bracket Cat {-# UNPACK #-} !FId String Fun [BracketedString]
-- ^ this is a bracket. The 'Cat' is the category of
-- the phrase. The 'FId' is an unique identifier for
-- every phrase in the sentence. For context-free grammars
-- i.e. without discontinuous constituents this identifier
-- is also unique for every bracket. When there are discontinuous
-- phrases then the identifiers are unique for every phrase but
-- not for every bracket since the bracket represents a constituent.
-- The different constituents could still be distinguished by using
-- the analysis string. If the grammar is reduplicating
-- then the constituent indices will be the same for all brackets
-- that represents the same constituent.
-- The 'Fun' is the name of the abstract function that generated
-- this phrase.
-- | Renders the bracketed string as a string where
-- the brackets are shown as @(S ...)@ where
-- @S@ is the category.
showBracketedString :: BracketedString -> String
showBracketedString = render . ppBracketedString
ppBracketedString (Leaf t) = text t
ppBracketedString BIND = text "&+"
ppBracketedString (Bracket cat fid _ _ bss) = parens (text cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
-- | Extracts the sequence of tokens from the bracketed string
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss
bracketedLinearize :: Concr -> Expr -> [BracketedString]
bracketedLinearize = error "TODO: bracketedLinearize"
bracketedLinearizeAll :: Concr -> Expr -> [[BracketedString]]
bracketedLinearizeAll = error "TODO: bracketedLinearizeAll"
generateAll :: PGF -> Type -> [(Expr,Float)]
generateAll p ty = error "TODO: generateAll"
generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
generateAllFrom p ty = error "TODO: generateAllFrom"
generateRandom :: StdGen -> PGF -> Type -> [a]
generateRandom = error "TODO: generateRandom"
generateRandomFrom :: StdGen -> PGF -> Expr -> [a]
generateRandomFrom = error "TODO: generateRandomFrom"
-- | List of all functions defined in the abstract syntax
categories :: PGF -> [Cat]
categories p =
@@ -184,7 +491,7 @@ categories p =
name <- peekText key
writeIORef ref $ (name : names)
categoryContext :: PGF -> Cat -> [Hypo]
categoryContext :: PGF -> Cat -> Maybe [Hypo]
categoryContext p cat =
unsafePerformIO $
withText cat $ \c_cat ->
@@ -195,11 +502,11 @@ categoryContext p cat =
mask_ $ do
c_hypos <- withPgfExn (pgf_category_context c_db c_revision c_cat p_n_hypos u)
if c_hypos == nullPtr
then return []
then return Nothing
else do n_hypos <- peek p_n_hypos
hypos <- peekHypos c_hypos 0 n_hypos
free c_hypos
return hypos
return (Just hypos)
where
peekHypos :: Ptr PgfTypeHypo -> CSize -> CSize -> IO [Hypo]
peekHypos c_hypo i n
@@ -214,8 +521,8 @@ categoryContext p cat =
return ((bt,cat,ty) : hs)
| otherwise = return []
categoryProb :: PGF -> Cat -> Float
categoryProb p cat =
categoryProbability :: PGF -> Cat -> Float
categoryProbability p cat =
unsafePerformIO $
withText cat $ \c_cat ->
withForeignPtr (a_db p) $ \c_db ->
@@ -291,6 +598,256 @@ abstractFlag p name =
freeStablePtr c_lit
return (Just lit)
-----------------------------------------------------------------------------
-- Graphviz
data GraphvizOptions = GraphvizOptions {noLeaves :: Bool,
noFun :: Bool,
noCat :: Bool,
noDep :: Bool,
nodeFont :: String,
leafFont :: String,
nodeColor :: String,
leafColor :: String,
nodeEdgeStyle :: String,
leafEdgeStyle :: String
}
graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
-- | Renders an abstract syntax tree in a Graphviz format.
graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
graphvizAbstractTree p opts e = error "TODO: graphvizAbstractTree"
graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
graphvizParseTree c opts e = error "TODO: graphvizParseTree"
graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
graphvizWordAlignment cs opts e = error "TODO: graphvizWordAlignment"
type Labels = Map.Map Fun [String]
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)]
-- | Visualize word dependency tree.
graphvizDependencyTree
:: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
-> Bool -- ^ Include extra information (debug)
-> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels'
-> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@))
-> Concr
-> Expr
-> String -- ^ Rendered output in the specified format
graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree"
---------------------- should be a separate module?
-- visualization with latex output. AR Nov 2015
conlls2latexDoc :: [String] -> String
conlls2latexDoc =
render .
latexDoc .
vcat .
intersperse (text "" $+$ app "vspace" (text "4mm")) .
map conll2latex .
filter (not . null)
conll2latex :: String -> Doc
conll2latex = ppLaTeX . conll2latex' . parseCoNLL
conll2latex' :: CoNLL -> [LaTeX]
conll2latex' = dep2latex . conll2dep'
data Dep = Dep {
wordLength :: Int -> Double -- length of word at position int -- was: fixed width, millimetres (>= 20.0)
, tokens :: [(String,String)] -- word, pos (0..)
, deps :: [((Int,Int),String)] -- from, to, label
, root :: Int -- root word position
}
-- some general measures
defaultWordLength = 20.0 -- the default fixed width word length, making word 100 units
defaultUnit = 0.2 -- unit in latex pictures, 0.2 millimetres
spaceLength = 10.0
charWidth = 1.8
wsize rwld w = 100 * rwld w + spaceLength -- word length, units
wpos rwld i = sum [wsize rwld j | j <- [0..i-1]] -- start position of the i'th word
wdist rwld x y = sum [wsize rwld i | i <- [min x y .. max x y - 1]] -- distance between words x and y
labelheight h = h + arcbase + 3 -- label just above arc; 25 would put it just below
labelstart c = c - 15.0 -- label starts 15u left of arc centre
arcbase = 30.0 -- arcs start and end 40u above the bottom
arcfactor r = r * 600 -- reduction of arc size from word distance
xyratio = 3 -- width/height ratio of arcs
putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
putArc frwld height x y label = [oval,arrowhead,labelling] where
oval = Put (ctr,arcbase) (OvalTop (wdth,hght))
arrowhead = Put (endp,arcbase + 5) (ArrowDown 5) -- downgoing arrow 5u above the arc base
labelling = Put (labelstart ctr,labelheight (hght/2)) (TinyText label)
dxy = wdist frwld x y -- distance between words, >>= 20.0
ndxy = 100 * rwld * fromIntegral height -- distance that is indep of word length
hdxy = dxy / 2 -- half the distance
wdth = dxy - (arcfactor rwld)/dxy -- longer arcs are wider in proportion
hght = ndxy / (xyratio * rwld) -- arc height is independent of word length
begp = min x y -- begin position of oval
ctr = wpos frwld begp + hdxy + (if x < y then 20 else 10) -- LR arcs are farther right from center of oval
endp = (if x < y then (+) else (-)) ctr (wdth/2) -- the point of the arrow
rwld = 0.5 ----
dep2latex :: Dep -> [LaTeX]
dep2latex d =
[Comment (unwords (map fst (tokens d))),
Picture defaultUnit (width,height) (
[Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))] -- words
++ [Put (wpos rwld i,15) (TinyText w) | (i,w) <- zip [0..] (map snd (tokens d))] -- pos tags 15u above bottom
++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d] -- arcs and labels
++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))]
++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")]
)]
where
wld i = wordLength d i -- >= 20.0
rwld i = (wld i) / defaultWordLength -- >= 1.0
aheight x y = depth (min x y) (max x y) + 1 ---- abs (x-y)
arcs = [(min u v, max u v) | ((u,v),_) <- deps d]
depth x y = case [(u,v) | (u,v) <- arcs, (x < u && v <= y) || (x == u && v < y)] of ---- only projective arcs counted
[] -> 0
uvs -> 1 + maximum (0:[depth u v | (u,v) <- uvs])
width = {-round-} (sum [wsize rwld w | (w,_) <- zip [0..] (tokens d)]) + {-round-} spaceLength * fromIntegral ((length (tokens d)) - 1)
height = 50 + 20 * {-round-} (maximum (0:[aheight x y | ((x,y),_) <- deps d]))
type CoNLL = [[String]]
parseCoNLL :: String -> CoNLL
parseCoNLL = map words . lines
--conll2dep :: String -> Dep
--conll2dep = conll2dep' . parseCoNLL
conll2dep' :: CoNLL -> Dep
conll2dep' ls = Dep {
wordLength = wld
, tokens = toks
, deps = dps
, root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1]
}
where
wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,pos) = toks !! i in [tok,pos]])
toks = [(w,c) | _:w:_:c:_ <- ls]
dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"]
--maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]
-- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture)
-- We render both LaTeX and SVG from this intermediate representation of
-- LaTeX pictures.
data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand]
data DrawingCommand = Put Position Object
data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length
type UnitLengthMM = Double
type Size = (Double,Double)
type Position = (Double,Double)
type Length = Double
-- * latex formatting
ppLaTeX = vcat . map ppLaTeX1
where
ppLaTeX1 el =
case el of
Comment s -> comment s
Picture unit size cmds ->
app "setlength{\\unitlength}" (text (show unit ++ "mm"))
$$ hang (app "begin" (text "picture")<>text (show size)) 2
(vcat (map ppDrawingCommand cmds))
$$ app "end" (text "picture")
$$ text ""
ppDrawingCommand (Put pos obj) = put pos (ppObject obj)
ppObject obj =
case obj of
Text s -> text s
TinyText s -> small (text s)
OvalTop size -> text "\\oval" <> text (show size) <> text "[t]"
ArrowDown len -> app "vector(0,-1)" (text (show len))
put p@(_,_) = app ("put" ++ show p)
small w = text "{\\tiny" <+> w <> text "}"
comment s = text "%%" <+> text s -- line break show follow
app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}"
latexDoc :: Doc -> Doc
latexDoc body =
vcat [text "\\documentclass{article}",
text "\\usepackage[utf8]{inputenc}",
text "\\begin{document}",
body,
text "\\end{document}"]
----------------------------------
-- concrete syntax annotations (local) on top of conll
-- examples of annotations:
-- UseComp {"not"} PART neg head
-- UseComp {*} AUX cop head
type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
-- (fun, word -> (pos,label,target))
-- the pos can remain unchanged, as in the current notation in the article
fixCoNLL :: CncLabels -> CoNLL -> CoNLL
fixCoNLL labels conll = map fixc conll where
fixc row = case row of
(i:word:fun:pos:cat:x_:"0":"dep":xs) -> (i:word:fun:pos:cat:x_:"0":"root":xs) --- change the root label from dep to root
(i:word:fun:pos:cat:x_:j:label:xs) -> case look (fun,word) of
Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:x_:j :label':xs)
Just (pos',label',target) -> (i:word:fun:pos' pos:cat:x_: getDep j target:label':xs)
_ -> row
_ -> row
look (fun,word) = case lookup fun labels of
Just relabel -> case relabel word of
Just row -> Just row
_ -> case lookup "*" labels of
Just starlabel -> starlabel word
_ -> Nothing
_ -> case lookup "*" labels of
Just starlabel -> starlabel word
_ -> Nothing
getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll]
getCncDepLabels :: String -> CncLabels
getCncDepLabels = map merge . groupBy (\ (x,_) (a,_) -> x == a) . concatMap analyse . filter choose . lines where
--- choose is for compatibility with the general notation
choose line = notElem '(' line && elem '{' line --- ignoring non-local (with "(") and abstract (without "{") rules
analyse line = case break (=='{') line of
(beg,_:ws) -> case break (=='}') ws of
(toks,_:target) -> case (words beg, words target) of
(fun:_,[ label,j]) -> [(fun, (tok, (id, label,j))) | tok <- getToks toks]
(fun:_,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | tok <- getToks toks]
_ -> []
_ -> []
_ -> []
merge rules@((fun,_):_) = (fun, \tok ->
case lookup tok (map snd rules) of
Just new -> return new
_ -> lookup "*" (map snd rules)
)
getToks = words . map (\c -> if elem c "\"," then ' ' else c)
printCoNLL :: CoNLL -> String
printCoNLL = unlines . map (concat . intersperse "\t")
-----------------------------------------------------------------------
-- Expressions & types
@@ -335,6 +892,12 @@ readExpr str =
freeStablePtr c_expr
return (Just expr)
pIdent :: ReadS String
pIdent = error "TODO: pIdent"
pExpr :: ReadS Expr
pExpr = error "TODO: pExpr"
-- | 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
@@ -348,6 +911,9 @@ showType scope ty =
bracket (pgf_print_type c_ty pctxt 0 m) free $ \c_text ->
peekText c_text
showContext :: [Var] -> [(BindType,Var,Type)] -> String
showContext = error "TODO: showContext"
-- | parses a 'String' as a type
readType :: String -> Maybe Type
readType str =
@@ -360,3 +926,8 @@ readType str =
else do ty <- deRefStablePtr c_ty
freeStablePtr c_ty
return (Just ty)
readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double)
readProbabilitiesFromFile fpath = do
s <- readFile fpath
return $ Map.fromList [(f,read p) | f:p:_ <- map words (lines s)]

11
src/runtime/haskell/PGF2/Expr.hs
View File

@@ -11,7 +11,7 @@ module PGF2.Expr(Var, Cat, Fun,
mkFloat, unFloat,
mkMeta, unMeta,
exprSize, exprFunctions,
exprSize, exprFunctions, exprSubstitute,
mkType, unType,
mkHypo, mkDepHypo, mkImplHypo
@@ -169,6 +169,15 @@ exprFunctions (EImplArg e) = exprFunctions e
exprFunctions (EFun f) = [f]
exprFunctions _ = []
exprSubstitute :: Expr -> [Expr] -> Expr
exprSubstitute (EAbs bt x e) vs = EAbs bt x (exprSubstitute e vs)
exprSubstitute (EApp e1 e2) vs = EApp (exprSubstitute e1 vs) (exprSubstitute e2 vs)
exprSubstitute (EMeta i) vs = vs !! i
exprSubstitute (ETyped e ty) vs = ETyped (exprSubstitute e vs) ty
exprSubstitute (EImplArg e) vs = EImplArg (exprSubstitute e vs)
exprSubstitute e vs = e
-- | creates a type from list of hypothesises, category and
-- list of arguments for the category. The operation
-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create

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

@@ -18,11 +18,14 @@ import PGF2.Expr
#include <pgf/pgf.h>
type AbsName = String -- ^ Name of abstract syntax
type ConcName = String -- ^ Name of concrete syntax
-- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format.
data PGF = PGF { a_db :: ForeignPtr PgfDB
, revision :: ForeignPtr PgfRevision
, langs :: Map.Map String Concr
, languages:: Map.Map ConcName Concr
}
data Concr = Concr {c_pgf :: ForeignPtr PgfDB, concr :: Ptr PgfConcr}

89
src/runtime/haskell/PGF2/Internal.hsc
View File

@@ -1,4 +1,93 @@
{-# LANGUAGE ImplicitParams, RankNTypes #-}
module PGF2.Internal(-- * Access the internal structures
FId,isPredefFId,
fidString,fidInt,fidFloat,fidVar,fidStart,
-- * Byte code
CodeLabel, Instr(..), IVal(..), TailInfo(..),
SeqId,LIndex,
FunId,Token,Production(..),PArg(..),Symbol(..),
unionPGF, writeConcr
) where
import PGF2.FFI
import PGF2.Expr
type Token = String
type LIndex = Int
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS Token
| SymKP [Symbol] [([Symbol],[String])]
| SymBIND -- the special BIND token
| SymNE -- non exist
| SymSOFT_BIND -- the special SOFT_BIND token
| SymSOFT_SPACE -- the special SOFT_SPACE token
| SymCAPIT -- the special CAPIT token
| SymALL_CAPIT -- the special ALL_CAPIT token
deriving (Eq,Ord,Show)
data Production
= PApply {-# UNPACK #-} !FunId [PArg]
| PCoerce {-# UNPACK #-} !FId
deriving (Eq,Ord,Show)
type FunId = Int
type SeqId = Int
type FId = Int
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
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
= CHECK_ARGS {-# UNPACK #-} !Int
| CASE Fun {-# UNPACK #-} !CodeLabel
| CASE_LIT Literal {-# UNPACK #-} !CodeLabel
| SAVE {-# UNPACK #-} !Int
| ALLOC {-# UNPACK #-} !Int
| PUT_CONSTR Fun
| PUT_CLOSURE {-# UNPACK #-} !CodeLabel
| PUT_LIT Literal
| SET IVal
| SET_PAD
| PUSH_FRAME
| PUSH IVal
| TUCK IVal {-# UNPACK #-} !Int
| EVAL IVal TailInfo
| DROP {-# UNPACK #-} !Int
| JUMP {-# UNPACK #-} !CodeLabel
| FAIL
| PUSH_ACCUM Literal
| POP_ACCUM
| ADD
data IVal
= HEAP {-# UNPACK #-} !Int
| ARG_VAR {-# UNPACK #-} !Int
| FREE_VAR {-# UNPACK #-} !Int
| GLOBAL Fun
deriving Eq
data TailInfo
= RecCall
| TailCall {-# UNPACK #-} !Int
| UpdateCall
unionPGF :: PGF -> PGF -> Maybe PGF
unionPGF = error "TODO: unionPGF"
writeConcr :: FilePath -> Concr -> IO ()
writeConcr = error "TODO: writeConcr"

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

@@ -91,7 +91,7 @@ branchPGF_ c_name p (Transaction f) =
ex_type <- (#peek PgfExn, type) c_exn
if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
then do fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
return (PGF (a_db p) fptr2 (langs p))
return (PGF (a_db p) fptr2 (languages p))
else do pgf_free_revision c_db c_revision
return p
else do pgf_free_revision c_db c_revision
@@ -107,7 +107,7 @@ checkoutPGF p name =
if c_revision == nullPtr
then return Nothing
else do fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
return (Just (PGF (a_db p) fptr2 (langs p)))
return (Just (PGF (a_db p) fptr2 (languages p)))
createFunction :: Fun -> Type -> Float -> Transaction ()
createFunction name ty prob = Transaction $ \c_db c_revision c_exn ->