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

cleanup

Browse Source
This commit is contained in:
krangelov
2019-09-19 22:30:08 +02:00
parent 4a71464ca7
commit acb70ccc1b
50 changed files with 537 additions and 1964 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -6,8 +6,8 @@ import GF.Infra.UseIO
import GF.Infra.Option
import GF.Compile.OptimizePGF
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -20,22 +20,22 @@ import Data.Maybe(fromMaybe)
-- the compiler ----------
--------------------------
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId Double -> PGF
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
cf2pgf opts fpath cf probs =
build (let abstr = cf2abstr cf probs
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
where
name = justModuleName fpath
aname = mkCId (name ++ "Abs")
cname = mkCId name
aname = name ++ "Abs"
cname = name
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo
cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
cf2abstr cfg probs = newAbstr aflags acats afuns
where
aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))]
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 wildCId (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]
@@ -53,12 +53,12 @@ cf2abstr cfg probs = newAbstr aflags acats afuns
toLogProb = realToFrac . negate . log
cat2id = mkCId . fst
cat2id = fst
cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
cf2concr opts abstr cfg =
let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF (mkCId (fst (cfgStartCat cfg))) else id)
(if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
(lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
in newConcr abstr [] []
lindefs' linrefs'
@@ -74,7 +74,7 @@ cf2concr opts abstr cfg =
map mkSequence rules)
sequences = Set.toList sequences0
idFun = (wildCId,[Set.findIndex idSeq sequences0])
idFun = ("_",[Set.findIndex idSeq sequences0])
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
cncfuns = reverse cncfuns0
@@ -100,11 +100,11 @@ cf2concr opts abstr cfg =
convertSymbol d (Terminal t) = (d, SymKS t)
mkCncCat fid (cat,n)
| cat == "Int" = (fid, (mkCId cat, fidInt, fidInt, lbls))
| cat == "Float" = (fid, (mkCId cat, fidFloat, fidFloat, lbls))
| cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls))
| cat == "Int" = (fid, (cat, fidInt, fidInt, lbls))
| cat == "Float" = (fid, (cat, fidFloat, fidFloat, lbls))
| cat == "String" = (fid, (cat, fidString, fidString, lbls))
| otherwise = let fid' = fid+n+1
in fid' `seq` (fid', (mkCId cat, fid, fid+n, lbls))
in fid' `seq` (fid', (cat, fid, fid+n, lbls))
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
mkCoercions (fid,cs) c@(cat,ps ) =
@@ -120,7 +120,7 @@ cf2concr opts abstr cfg =
Nothing -> IntMap.insert fid [prod] prods
cat2fid cat p =
case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of
case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
(start:_) -> fid+p
_ -> error "cat2fid"
@@ -133,5 +133,5 @@ cf2concr opts abstr cfg =
mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> wildCId
_ -> "_"

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

@@ -1,6 +1,6 @@
module GF.Compile.Compute.Value where
import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
import PGF.Internal(BindType)
import PGF2(BindType)
import GF.Infra.Ident(Ident)
import Text.Show.Functions()
import Data.Ix(Ix)

35
src/compiler/GF/Compile/ExampleBased.hs
View File

@@ -3,11 +3,7 @@ module GF.Compile.ExampleBased (
configureExBased
) where
import PGF
--import PGF.Probabilistic
--import PGF.Morphology
--import GF.Compile.ToAPI
import PGF2
import Data.List
parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
@@ -37,47 +33,38 @@ convertFile conf src file = do
(ex, end) = break (=='"') (tail exend)
in ((unwords (words cat),ex), tail end) -- quotes ignored
pgf = resource_pgf conf
morpho = resource_morpho conf
lang = language conf
convEx (cat,ex) = do
appn "("
let typ = maybe (error "no valid cat") id $ readType cat
ws <- case fst (parse_ pgf lang typ (Just 4) ex) of
ParseFailed _ -> do
let ws = morphoMissing morpho (words ex)
ws <- case parse lang typ ex of
ParseFailed _ _ -> do
appv ("WARNING: cannot parse example " ++ ex)
case ws of
[] -> return ()
_ -> appv (" missing words: " ++ unwords ws)
return ws
TypeError _ ->
return []
ParseIncomplete ->
return []
ParseOk ts ->
case rank ts of
case ts of
(t:tt) -> do
if null tt
then return ()
else appv ("WARNING: ambiguous example " ++ ex)
appn t
mapM_ (appn . (" --- " ++)) tt
appn (printExp conf (fst t))
mapM_ (appn . (" --- " ++) . printExp conf . fst) tt
appn ")"
return []
return ws
rank ts = [printExp conf t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
appf = appendFile file
appn s = appf s >> appf "\n"
appv s = appn ("--- " ++ s) >> putStrLn s
data ExConfiguration = ExConf {
resource_pgf :: PGF,
resource_morpho :: Morpho,
resource_pgf :: PGF,
verbose :: Bool,
language :: Language,
printExp :: Tree -> String
language :: Concr,
printExp :: Expr -> String
}
configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
configureExBased pgf concr pr = ExConf pgf False concr pr

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

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

25
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG, resourceValues
) where
--import PGF.CId
import PGF.Internal as PGF(CId,Symbol(..),fidVar)
import qualified PGF2 as PGF2
import qualified PGF2.Internal as PGF2
import PGF2.Internal(Symbol(..),fidVar)
import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -68,7 +69,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -92,7 +93,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
seqs1 `seq` stats `seq` return ()
when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
return (seqs1,CncFun mty mlin mprn (Just pmcfg))
where
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
@@ -102,11 +103,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (MN identW,cVar) typeStr
@@ -131,7 +132,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
let pmcfg = getPMCFG pmcfgEnv2
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
where
addLindef lins (newCat', newArgs') env0 =
let [newCat] = getFIds newCat'
@@ -157,7 +158,7 @@ convert opts gr cenv loc term ty@(_,val) pargs =
args = map Vr vars
vars = map (\(bt,x,t) -> x) context
pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String])
pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
pgfCncCat gr id lincat index =
let ((_,size),schema) = computeCatRange gr lincat
in ( id
@@ -474,7 +475,7 @@ goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
----------------------------------------------------------------------
-- SeqSet
type SeqSet = Map.Map Sequence SeqId
type SeqSet = Map.Map [Symbol] SeqId
addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b

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

@@ -18,7 +18,7 @@ import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF)
import PGF.Internal(Literal(..))
import PGF2.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import Debug.Trace

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

@@ -1,8 +1,8 @@
{-# LANGUAGE BangPatterns #-}
module GF.Compile.OptimizePGF(optimizePGF) where
import PGF(mkCId)
import PGF.Internal
import PGF2(Cat,Fun)
import PGF2.Internal
import Data.Array.ST
import Data.Array.Unboxed
import qualified Data.Map as Map
@@ -15,19 +15,19 @@ import Control.Monad.ST
type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
[(FId,[FunId])], -- ^ Linrefs
[(FId,[Production])], -- ^ Productions
[(CId,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
[(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun)
[[Symbol]], -- ^ Sequences (must be sorted)
[(CId,FId,FId,[String])]) -- ^ Concrete categories
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
optimizePGF :: CId -> ConcrData -> ConcrData
optimizePGF :: Cat -> ConcrData -> ConcrData
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
cidString = mkCId "String"
cidInt = mkCId "Int"
cidFloat = mkCId "Float"
cidVar = mkCId "__gfVar"
topDownFilter :: CId -> ConcrData -> ConcrData
catString = "String"
catInt = "Int"
catFloat = "Float"
catVar = "__gfVar"
topDownFilter :: Cat -> ConcrData -> ConcrData
topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
let env0 = (Map.empty,Map.empty)
(env1,lindefs') = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
@@ -43,10 +43,10 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
(sequences',cncfuns') = env3
in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray sequences',cnccats')
where
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (CId, [SeqId])
cncfuns_array = listArray (0,length cncfuns-1) cncfuns :: Array FunId (Fun, [SeqId])
sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
prods_map = IntMap.fromList prods
fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
fid2catMap = IntMap.fromList ((fidVar,catVar) : [(fid,cat) | (cat,start,end,lbls) <- cnccats,
fid <- [start..end]])
fid2cat fid =
@@ -76,17 +76,17 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
-- An element of the array is equal to -1 if the corresponding index
-- is not going to be used in the optimized grammar, or the new index
-- if it will be used
closure :: Map.Map CId [LIndex]
closure :: Map.Map Cat [Int]
closure = runST $ do
set <- initSet
addLitCat cidString set
addLitCat cidInt set
addLitCat cidFloat set
addLitCat cidVar set
addLitCat catString set
addLitCat catInt set
addLitCat catFloat set
addLitCat catVar set
closureSet set starts
doneSet set
where
initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
initSet :: ST s (Map.Map Cat (STUArray s Int Int))
initSet =
fmap Map.fromList $ sequence
[fmap ((,) cat) (newArray (0,length lbls-1) (-1))
@@ -109,7 +109,7 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
else closureSet set xs
Nothing -> error "unknown cat"
doneSet :: Map.Map CId (STUArray s LIndex LIndex) -> ST s (Map.Map CId [LIndex])
doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
doneSet set =
fmap Map.fromAscList $ mapM done (Map.toAscList set)
where

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

@@ -16,8 +16,8 @@
module GF.Compile.PGFtoHaskell (grammar2haskell) where
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import GF.Data.Operations
import GF.Infra.Option
@@ -242,7 +242,7 @@ fInstance gId lexical m (cat,rules) =
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
(if lexical cat then " Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
where
isList = isListCat (cat,rules)
@@ -263,11 +263,11 @@ fInstance gId lexical m (cat,rules) =
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(showCId (abstractName gr),
(abstractName gr,
let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) |
[(c, [(f, cs) | (f, cs,_) <- fs]) |
fs@((_, _,c):_) <- fns]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
)
where
cts = categories gr

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

@@ -1,156 +1,110 @@
module GF.Compile.PGFtoJSON (pgf2json) where
import PGF (showCId)
import qualified PGF.Internal as M
import PGF.Internal (
Abstr,
CId,
CncCat(..),
CncFun(..),
Concr,
DotPos,
Equation(..),
Literal(..),
PArg(..),
PGF,
Production(..),
Symbol(..),
Type,
absname,
abstract,
cflags,
cnccats,
cncfuns,
concretes,
funs,
productions,
sequences,
totalCats
)
import qualified Text.JSON as JSON
import Text.JSON (JSValue(..))
import qualified Data.Array.IArray as Array
import Data.Map (Map)
import qualified Data.Set as Set
import PGF2
import PGF2.Internal
import Text.JSON
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2json :: PGF -> String
pgf2json pgf =
JSON.encode $ JSON.makeObj
[ ("abstract", json_abstract)
, ("concretes", json_concretes)
]
where
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = showCId $ M.lookStartCat pgf
json_abstract = abstract2json n start as
json_concretes = JSON.makeObj $ map concrete2json cs
abstract2json :: String -> String -> Abstr -> JSValue
abstract2json name start ds =
JSON.makeObj
[ ("name", mkJSStr name)
, ("startcat", mkJSStr start)
, ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
]
absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
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
(args,cat) = M.catSkeleton typ
sig = JSON.makeObj
[ ("args", JSArray $ map (mkJSStr.showCId) args)
, ("cat", mkJSStr $ showCId cat)
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) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)
lit2json (LStr s) = showJSON s
lit2json (LInt n) = showJSON n
lit2json (LFlt d) = showJSON d
concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId c,obj)
concrete2json :: (ConcName,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (c,obj)
where
obj = JSON.makeObj
[ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
, ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
, ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
, ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
, ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
, ("totalfids", mkJSInt (totalCats cnc))
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))
]
cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
cat2json (cat,start,end,_) = (cat, ixs)
where
ixs = JSON.makeObj
[ ("start", mkJSInt start)
, ("end", mkJSInt end)
ixs = makeObj
[ ("start", showJSON start)
, ("end", showJSON end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
JSON.makeObj
[ ("type", mkJSStr "Apply")
, ("fid", mkJSInt fid)
, ("args", JSArray (map farg2json args))
makeObj
[ ("type", showJSON "Apply")
, ("fid", showJSON fid)
, ("args", showJSON (map farg2json args))
]
frule2json (PCoerce arg) =
JSON.makeObj
[ ("type", mkJSStr "Coerce")
, ("arg", mkJSInt arg)
makeObj
[ ("type", showJSON "Coerce")
, ("arg", showJSON arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
JSON.makeObj
[ ("type", mkJSStr "PArg")
, ("hypos", JSArray $ map (mkJSInt . snd) hypos)
, ("fid", mkJSInt fid)
makeObj
[ ("type", showJSON "PArg")
, ("hypos", JSArray $ map (showJSON . snd) hypos)
, ("fid", showJSON fid)
]
ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
JSON.makeObj
[ ("name", mkJSStr $ showCId f)
, ("lins", JSArray (map mkJSInt (Array.elems lins)))
ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
ffun2json funid (fun,seqids) =
makeObj
[ ("name", showJSON fun)
, ("lins", showJSON seqids)
]
seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
seq2json :: SeqId -> [Symbol] -> JSValue
seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
sym2json :: Symbol -> JSValue
sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l]
sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l]
sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l]
sym2json (SymKS t) = new "SymKS" [mkJSStr t]
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" [mkJSStr "&+"]
sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"]
sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"]
sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"]
sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"]
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" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
new :: String -> [JSValue] -> JSValue
new f xs =
JSON.makeObj
[ ("type", mkJSStr f)
, ("args", JSArray xs)
makeObj
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-- | Make JSON value from string
mkJSStr :: String -> JSValue
mkJSStr = JSString . JSON.toJSString
-- | Make JSON value from integer
mkJSInt :: Integral a => a -> JSValue
mkJSInt = JSRational False . toRational

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

@@ -1,6 +1,6 @@
module GF.Compile.PGFtoJava (grammar2java) where
import PGF
import PGF2
import Data.Maybe(maybe)
import Data.List(intercalate)
import GF.Infra.Option
@@ -24,9 +24,8 @@ javaPreamble name =
]
javaMethod gr fun =
" public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }"
" public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
where
name = showCId fun
arity = maybe 0 getArrity (functionType gr fun)
vars = ['e':show i | i <- [1..arity]]

30
src/compiler/GF/Compile/ToAPI.hs
View File

@@ -2,7 +2,7 @@ module GF.Compile.ToAPI
(stringToAPI,exprToAPI)
where
import PGF
import PGF2
import Data.Maybe
--import System.IO
--import Control.Monad
@@ -46,12 +46,12 @@ exprToFunc :: Expr -> APIfunc
exprToFunc expr =
case unApp expr of
Just (cid,l) ->
case Map.lookup (showCId cid) syntaxFuncs of
case Map.lookup cid syntaxFuncs of
Just sig -> mkAPI True (fst sig,expr)
_ -> case l of
[] -> BasicFunc (showCId cid)
[] -> BasicFunc cid
_ -> let es = map exprToFunc l
in AppFunc (showCId cid) es
in AppFunc cid es
_ -> BasicFunc (showExpr [] expr)
@@ -68,8 +68,8 @@ mkAPI opt (ty,expr) =
where
rephraseSentence ty expr =
case unApp expr of
Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then
let newCat = drop 3 (showCId cid)
Just (cid,es) -> if isPrefixOf "Use" cid then
let newCat = drop 3 cid
afClause = mkAPI True (newCat, es !! 2)
afPol = mkAPI True ("Pol",es !! 1)
lTense = mkAPI True ("Temp", head es)
@@ -97,9 +97,9 @@ mkAPI opt (ty,expr) =
computeAPI :: (String,Expr) -> APIfunc
computeAPI (ty,expr) =
case (unApp expr) of
Just (cid,[]) -> getSimpCat (showCId cid) ty
Just (cid,[]) -> getSimpCat cid ty
Just (cid,es) ->
let p = specFunction (showCId cid) es
let p = specFunction cid es
in if isJust p then fromJust p
else case Map.lookup (show cid) syntaxFuncs of
Nothing -> exprToFunc expr
@@ -146,23 +146,23 @@ optimize expr = optimizeNP expr
optimizeNP expr =
case unApp expr of
Just (cid,es) ->
if showCId cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
if cid == "MassNP" then let afs = nounAsCN (head es)
in AppFunc "mkNP" [afs]
else if cid == "DetCN" then let quants = quantAsDet (head es)
ns = nounAsCN (head $ tail es)
in AppFunc "mkNP" (quants ++ [ns])
else mkAPI False ("NP",expr)
_ -> error $ "incorrect expression " ++ (showExpr [] expr)
where
nounAsCN expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
Just (cid,es) -> if cid == "UseN" then (mkAPI False) ("N",head es)
else (mkAPI False) ("CN",expr)
_ -> error $ "incorrect expression "++ (showExpr [] expr)
quantAsDet expr =
case unApp expr of
Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
Just (cid,es) -> if cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
else [mkAPI False ("Det",expr)]
_ -> error $ "incorrect expression "++ (showExpr [] expr)