mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Merge branch 'c-runtime' into compact-pgf
This commit is contained in:
krangelov
@@ -35,7 +35,7 @@ cf2abstr cfg probs = newAbstr aflags acats afuns
|
||||
aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
|
||||
|
||||
acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
|
||||
afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
|
||||
afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
|
||||
| rule <- allRules cfg
|
||||
, let f' = mkRuleName rule]
|
||||
|
||||
|
||||
@@ -57,9 +57,10 @@ grammar2PGF opts gr am probs = do
|
||||
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
|
||||
|
||||
funs = [(f', mkType [] ty, arity, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
|
||||
funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
|
||||
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
|
||||
let arity = mkArity ma mdef ty,
|
||||
let bcode = mkDef gr arity mdef,
|
||||
let f' = i2i f]
|
||||
|
||||
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
|
||||
@@ -173,12 +174,10 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
|
||||
in if x == identW
|
||||
then ( scope,hypo bt (i2i x) ty')
|
||||
else (x:scope,hypo bt (i2i x) ty')) scope hyps
|
||||
{-
|
||||
mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
|
||||
,generateByteCode gr arity eqs
|
||||
)
|
||||
mkDef gr arity Nothing = Nothing
|
||||
-}
|
||||
|
||||
mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
|
||||
mkDef gr arity Nothing = []
|
||||
|
||||
mkArity (Just a) _ ty = a -- known arity, i.e. defined function
|
||||
mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom
|
||||
mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module PGF (PGF, readPGF, showPGF,
|
||||
module PGF (PGF2.PGF, readPGF, showPGF,
|
||||
abstractName,
|
||||
|
||||
CId, mkCId, wildCId, showCId, readCId,
|
||||
@@ -22,7 +22,7 @@ module PGF (PGF, readPGF, showPGF,
|
||||
PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
|
||||
mkType, unType,
|
||||
|
||||
Token,
|
||||
PGF2.Token, PGF2.FId,
|
||||
|
||||
Language, readLanguage, showLanguage,
|
||||
languages, startCat, languageCode,
|
||||
@@ -51,14 +51,23 @@ module PGF (PGF, readPGF, showPGF,
|
||||
groupResults, conlls2latexDoc, gizaAlignment
|
||||
) where
|
||||
|
||||
import PGF.Internal
|
||||
import qualified PGF2
|
||||
import qualified PGF2 as PGF2
|
||||
import qualified PGF2.Internal as PGF2
|
||||
import qualified Data.Map as Map
|
||||
import qualified Text.ParserCombinators.ReadP as RP
|
||||
import Data.List(sortBy)
|
||||
import Text.PrettyPrint(text)
|
||||
import Data.Char(isDigit)
|
||||
|
||||
newtype CId = CId String deriving (Show,Read,Eq,Ord)
|
||||
|
||||
type Language = CId
|
||||
|
||||
lookConcr gr (CId lang) =
|
||||
case Map.lookup lang (PGF2.languages gr) of
|
||||
Just cnc -> cnc
|
||||
Nothing -> error "Unknown language"
|
||||
|
||||
readPGF = PGF2.readPGF
|
||||
|
||||
showPGF gr = PGF2.showPGF gr
|
||||
@@ -129,7 +138,7 @@ type TcError = String
|
||||
-- | This data type encodes the different outcomes which you could get from the parser.
|
||||
data ParseOutput
|
||||
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
|
||||
| TypeError [(FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
|
||||
| TypeError [(PGF2.FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
|
||||
-- The forest id ('FId') points to the bracketed string from the parser
|
||||
-- where the type checking failed. More than one error is returned
|
||||
-- if there are many analizes for some phrase but they all are not type correct.
|
||||
@@ -189,7 +198,7 @@ exprFunctions e = [CId f | f <- PGF2.exprFunctions e]
|
||||
compute = error "compute is not implemented"
|
||||
|
||||
-- | rank from highest to lowest probability
|
||||
rankTreesByProbs :: PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
|
||||
rankTreesByProbs :: PGF2.PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
|
||||
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
|
||||
[(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts]
|
||||
|
||||
@@ -212,7 +221,7 @@ graphvizDependencyTree format debug lbls cnclbls pgf lang e =
|
||||
in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
|
||||
graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented"
|
||||
|
||||
browse :: PGF -> CId -> Maybe (String,[CId],[CId])
|
||||
browse :: PGF2.PGF -> CId -> Maybe (String,[CId],[CId])
|
||||
browse = error "browse is not implemented"
|
||||
|
||||
-- | A type for plain applicative trees
|
||||
|
||||
@@ -1,163 +0,0 @@
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
module PGF.Internal(CId(..),Language,PGF2.PGF,
|
||||
PGF2.Concr,lookConcr,
|
||||
PGF2.FId,isPredefFId,
|
||||
PGF2.FunId,PGF2.SeqId,PGF2.LIndex,PGF2.Token,
|
||||
PGF2.Production(..),PGF2.PArg(..),PGF2.Symbol(..),PGF2.Literal(..),PGF2.BindType(..),Sequence,
|
||||
globalFlags, abstrFlags, concrFlags,
|
||||
concrTotalCats, concrCategories, concrProductions,
|
||||
concrTotalFuns, concrFunction,
|
||||
concrTotalSeqs, concrSequence,
|
||||
|
||||
PGF2.CodeLabel, PGF2.Instr(..), PGF2.IVal(..), PGF2.TailInfo(..),
|
||||
|
||||
PGF2.Builder, PGF2.B, PGF2.build,
|
||||
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
|
||||
PGF2.AbstrInfo, newAbstr, PGF2.ConcrInfo, newConcr, newPGF,
|
||||
|
||||
-- * Write an in-memory PGF to a file
|
||||
writePGF, writeConcr,
|
||||
|
||||
PGF2.fidString, PGF2.fidInt, PGF2.fidFloat, PGF2.fidVar, PGF2.fidStart,
|
||||
|
||||
ppFunId, ppSeqId, ppFId, ppMeta, ppLit, ppSeq,
|
||||
|
||||
unionPGF
|
||||
) where
|
||||
|
||||
import qualified PGF2
|
||||
import qualified PGF2.Internal as PGF2
|
||||
import qualified Data.Map as Map
|
||||
import PGF2.FFI(PGF(..))
|
||||
import Data.Array.IArray
|
||||
import Data.Array.Unboxed
|
||||
import Text.PrettyPrint
|
||||
|
||||
newtype CId = CId String deriving (Show,Read,Eq,Ord)
|
||||
|
||||
type Language = CId
|
||||
|
||||
lookConcr (PGF _ langs _) (CId lang) =
|
||||
case Map.lookup lang langs of
|
||||
Just cnc -> cnc
|
||||
Nothing -> error "Unknown language"
|
||||
|
||||
globalFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.globalFlags pgf]
|
||||
abstrFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.abstrFlags pgf]
|
||||
concrFlags concr = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.concrFlags concr]
|
||||
|
||||
concrTotalCats = PGF2.concrTotalCats
|
||||
|
||||
concrCategories :: PGF2.Concr -> [(CId,PGF2.FId,PGF2.FId,[String])]
|
||||
concrCategories c = [(CId cat,start,end,lbls) | (cat,start,end,lbls) <- PGF2.concrCategories c]
|
||||
|
||||
concrProductions :: PGF2.Concr -> PGF2.FId -> [PGF2.Production]
|
||||
concrProductions = PGF2.concrProductions
|
||||
|
||||
concrTotalFuns = PGF2.concrTotalFuns
|
||||
|
||||
concrFunction :: PGF2.Concr -> PGF2.FunId -> (CId,[PGF2.SeqId])
|
||||
concrFunction c funid =
|
||||
let (fun,seqids) = PGF2.concrFunction c funid
|
||||
in (CId fun,seqids)
|
||||
|
||||
concrTotalSeqs :: PGF2.Concr -> PGF2.SeqId
|
||||
concrTotalSeqs = PGF2.concrTotalSeqs
|
||||
|
||||
concrSequence = PGF2.concrSequence
|
||||
|
||||
isPredefFId = PGF2.isPredefFId
|
||||
|
||||
type Sequence = [PGF2.Symbol]
|
||||
|
||||
eAbs :: (?builder :: PGF2.Builder s) => PGF2.BindType -> CId -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
||||
eAbs bind_type (CId var) body = PGF2.eAbs bind_type var body
|
||||
|
||||
eApp :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
||||
eApp = PGF2.eApp
|
||||
|
||||
eMeta :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
|
||||
eMeta = PGF2.eMeta
|
||||
|
||||
eFun (CId fun) = PGF2.eFun fun
|
||||
|
||||
eVar :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr
|
||||
eVar = PGF2.eVar
|
||||
|
||||
eLit :: (?builder :: PGF2.Builder s) => PGF2.Literal -> PGF2.B s PGF2.Expr
|
||||
eLit = PGF2.eLit
|
||||
|
||||
eTyped :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Type -> PGF2.B s PGF2.Expr
|
||||
eTyped = PGF2.eTyped
|
||||
|
||||
eImplArg :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr
|
||||
eImplArg = PGF2.eImplArg
|
||||
|
||||
dTyp :: (?builder :: PGF2.Builder s) => [PGF2.B s (PGF2.BindType,String,PGF2.Type)] -> CId -> [PGF2.B s PGF2.Expr] -> PGF2.B s PGF2.Type
|
||||
dTyp hypos (CId cat) es = PGF2.dTyp hypos cat es
|
||||
|
||||
hypo bind_type (CId var) ty = PGF2.hypo bind_type var ty
|
||||
|
||||
newAbstr flags cats funs = PGF2.newAbstr [(flag,lit) | (CId flag,lit) <- flags]
|
||||
[(cat,hypos,prob) | (CId cat,hypos,prob) <- cats]
|
||||
[(fun,ty,arity,prob) | (CId fun,ty,arity,prob) <- funs]
|
||||
|
||||
newConcr abs flags printnames lindefs linrefs prods cncfuns seqs cnccats total_ccats =
|
||||
PGF2.newConcr abs [(flag,lit) | (CId flag,lit) <- flags]
|
||||
[(id,name) | (CId id,name) <- printnames]
|
||||
lindefs linrefs
|
||||
prods
|
||||
[(fun,seq_ids) | (CId fun,seq_ids) <- cncfuns]
|
||||
seqs
|
||||
[(cat,start,end,labels) | (CId cat,start,end,labels) <- cnccats]
|
||||
total_ccats
|
||||
|
||||
newPGF flags (CId name) abstr concrs =
|
||||
PGF2.newPGF [(flag,lit) | (CId flag,lit) <- flags]
|
||||
name
|
||||
abstr
|
||||
[(name,concr) | (CId name,concr) <- concrs]
|
||||
|
||||
writePGF = PGF2.writePGF
|
||||
writeConcr fpath pgf lang = PGF2.writeConcr fpath (lookConcr pgf lang)
|
||||
|
||||
|
||||
ppFunId funid = char 'F' <> int funid
|
||||
ppSeqId seqid = char 'S' <> int seqid
|
||||
|
||||
ppFId fid
|
||||
| fid == PGF2.fidString = text "CString"
|
||||
| fid == PGF2.fidInt = text "CInt"
|
||||
| fid == PGF2.fidFloat = text "CFloat"
|
||||
| fid == PGF2.fidVar = text "CVar"
|
||||
| fid == PGF2.fidStart = text "CStart"
|
||||
| otherwise = char 'C' <> int fid
|
||||
|
||||
ppMeta :: Int -> Doc
|
||||
ppMeta n
|
||||
| n == 0 = char '?'
|
||||
| otherwise = char '?' <> int n
|
||||
|
||||
ppLit (PGF2.LStr s) = text (show s)
|
||||
ppLit (PGF2.LInt n) = int n
|
||||
ppLit (PGF2.LFlt d) = double d
|
||||
|
||||
ppSeq (seqid,seq) =
|
||||
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol seq)
|
||||
|
||||
ppSymbol (PGF2.SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
|
||||
ppSymbol (PGF2.SymLit d r) = char '{' <> int d <> comma <> int r <> char '}'
|
||||
ppSymbol (PGF2.SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>'
|
||||
ppSymbol (PGF2.SymKS t) = doubleQuotes (text t)
|
||||
ppSymbol PGF2.SymNE = text "nonExist"
|
||||
ppSymbol PGF2.SymBIND = text "BIND"
|
||||
ppSymbol PGF2.SymSOFT_BIND = text "SOFT_BIND"
|
||||
ppSymbol PGF2.SymSOFT_SPACE= text "SOFT_SPACE"
|
||||
ppSymbol PGF2.SymCAPIT = text "CAPIT"
|
||||
ppSymbol PGF2.SymALL_CAPIT = text "ALL_CAPIT"
|
||||
ppSymbol (PGF2.SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts)))
|
||||
|
||||
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps)
|
||||
|
||||
unionPGF = PGF2.unionPGF
|
||||
|
||||
@@ -519,12 +519,12 @@ data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCa
|
||||
|
||||
newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
|
||||
[(Cat,[B s Hypo],Float)] ->
|
||||
[(Fun,B s Type,Int,Float)] ->
|
||||
[(Fun,B s Type,Int,[[Instr]],Float)] ->
|
||||
B s AbstrInfo
|
||||
newAbstr aflags cats funs = unsafePerformIO $ do
|
||||
c_aflags <- newFlags aflags pool
|
||||
(c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
|
||||
(c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
|
||||
(c_funs,absfuns) <- newAbsFuns (sortByFst5 funs) pool
|
||||
c_abs_lin_fun <- newAbsLinFun
|
||||
c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool
|
||||
return (B (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch))
|
||||
@@ -559,7 +559,7 @@ newAbstr aflags cats funs = unsafePerformIO $ do
|
||||
absfuns <- pokeAbsFun ptr absfuns x
|
||||
pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs
|
||||
|
||||
pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do
|
||||
pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,_,prob) = do
|
||||
pfun <- gu_alloc_variant (#const PGF_EXPR_FUN)
|
||||
(fromIntegral ((#size PgfExprFun)+utf8Length name))
|
||||
(#const gu_flex_alignof(PgfExprFun))
|
||||
@@ -1037,6 +1037,6 @@ writeConcr fpath c = do
|
||||
else do gu_pool_free pool
|
||||
return ()
|
||||
|
||||
sortByFst = sortBy (\(x,_) (y,_) -> compare x y)
|
||||
sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y)
|
||||
sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y)
|
||||
sortByFst = sortBy (\(x,_) (y,_) -> compare x y)
|
||||
sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y)
|
||||
sortByFst5 = sortBy (\(x,_,_,_,_) (y,_,_,_,_) -> compare x y)
|
||||
|
||||
@@ -16,7 +16,7 @@ cabal-version: >=1.10
|
||||
library
|
||||
exposed-modules: PGF2, PGF2.Internal, SG,
|
||||
-- backwards compatibility API:
|
||||
PGF, PGF.Internal
|
||||
PGF
|
||||
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
|
||||
build-depends: base >=4.3, containers, pretty, array, random
|
||||
-- hs-source-dirs:
|
||||
|
||||
Reference in New Issue
Block a user