msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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

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

@@ -7,7 +7,6 @@ import GF.Infra.Option
import GF.Compile.OptimizePGF
import PGF2
import PGF2.Internal
import qualified Data.Set as Set
import qualified Data.Map as Map

2
src/compiler/GF/Compile/Export.hs
View File

@@ -4,7 +4,6 @@ import PGF2
import GF.Compile.PGFtoHaskell
--import GF.Compile.PGFtoAbstract
import GF.Compile.PGFtoJava
import GF.Compile.PGFtoJSON
import GF.Infra.Option
--import GF.Speech.CFG
import GF.Speech.PGFToCFG
@@ -35,7 +34,6 @@ exportPGF opts fmt pgf =
FmtPGFPretty -> multi "txt" (showPGF)
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
FmtCanonicalJson-> []
FmtJSON -> multi "json" pgf2json
FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtJava -> multi "java" (grammar2java opts name)
FmtBNF -> single "bnf" bnfPrinter

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

@@ -5,7 +5,7 @@ import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF2(Literal(..))
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
import PGF2.ByteCode
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)
@@ -19,9 +19,7 @@ generateByteCode gr arity eqs =
b = if arity == 0 || null eqs
then instrs
else CHECK_ARGS arity:instrs
in case bs of
[[FAIL]] -> [] -- in the runtime this is a more efficient variant of [[FAIL]]
_ -> reverse bs
in reverse bs
where
is = push_is (arity-1) arity []

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

@@ -48,7 +48,7 @@ grammar2PGF opts gr am probs = do
pgf <- modifyPGF pgf $ do
sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs]
forM_ (allConcretes gr am) $ \cm ->
createConcrete (mi2i cm) $ do
let cflags = err (const noOptions) mflags (lookupModule gr cm)

1
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -17,7 +17,6 @@
module GF.Compile.PGFtoHaskell (grammar2haskell) where
import PGF2
import PGF2.Internal
import GF.Data.Operations
import GF.Infra.Option

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

@@ -1,111 +0,0 @@
module GF.Compile.PGFtoJSON (pgf2json) where
import PGF2
import PGF2.Internal
import Text.JSON
import qualified Data.Map as Map
pgf2json :: PGF -> String
pgf2json pgf = error "TODO: pgf2json"
{- encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
]
abstract2json :: PGF -> JSValue
abstract2json pgf =
makeObj
[ ("name", showJSON (abstractName pgf))
, ("startcat", showJSON (showType [] (startCat pgf)))
, ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
]
absdef2json :: PGF -> Fun -> (String,JSValue)
absdef2json pgf f = (f,sig)
where
Just (hypos,cat,_) = fmap unType (functionType pgf f)
sig = makeObj
[ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
, ("cat", showJSON cat)
]
lit2json :: Literal -> JSValue
lit2json (LStr s) = showJSON s
lit2json (LInt n) = showJSON n
lit2json (LFlt d) = showJSON d
concrete2json :: (ConcName,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (c,obj)
where
obj = makeObj
[ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
, ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
, ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
, ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
, ("categories", makeObj $ map cat2json (concrCategories cnc))
, ("totalfids", showJSON (concrTotalCats cnc))
]
cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
cat2json (cat,start,end,_) = (cat, ixs)
where
ixs = makeObj
[ ("start", showJSON start)
, ("end", showJSON end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
makeObj
[ ("type", showJSON "Apply")
, ("fid", showJSON fid)
, ("args", showJSON (map farg2json args))
]
frule2json (PCoerce arg) =
makeObj
[ ("type", showJSON "Coerce")
, ("arg", showJSON arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
makeObj
[ ("type", showJSON "PArg")
, ("hypos", JSArray $ map (showJSON . snd) hypos)
, ("fid", showJSON fid)
]
ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
ffun2json funid (fun,seqids) =
makeObj
[ ("name", showJSON fun)
, ("lins", showJSON seqids)
]
seq2json :: SeqId -> [Symbol] -> JSValue
seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
sym2json :: Symbol -> JSValue
sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l]
sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l]
sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l]
sym2json (SymKS t) = new "SymKS" [showJSON t]
sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)]
sym2json SymBIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"]
sym2json SymCAPIT = new "SymKS" [showJSON "&|"]
sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"]
sym2json SymNE = new "SymNE" []
alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
new :: String -> [JSValue] -> JSValue
new f xs =
makeObj
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-}