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

Merge with master and drop the Haskell runtime completely

Browse Source
This commit is contained in:
krangelov
2019-09-19 22:01:57 +02:00
parent e993ae59f8 9d3badd8b2
commit 4a71464ca7
488 changed files with 8762 additions and 39251 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/compiler/GF.hs
View File

@@ -19,7 +19,9 @@ module GF(
module GF.Grammar.Printer,
module GF.Infra.Ident,
-- ** Binary serialisation
module GF.Grammar.Binary
module GF.Grammar.Binary,
-- * Canonical GF
module GF.Compile.GrammarToCanonical
) where
import GF.Main
import GF.Compiler
@@ -36,3 +38,5 @@ import GF.Grammar.Macros
import GF.Grammar.Printer
import GF.Infra.Ident
import GF.Grammar.Binary
import GF.Compile.GrammarToCanonical

16
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -146,11 +146,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js
CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js
_ -> return $ updateTree i js
CncCat {} ->
case lookupOrigInfo gr (am,c) of
Ok (_,AbsCat _) -> return $ updateTree i js
{- -- This might be too pedantic:
Ok (_,AbsFun {}) ->
checkError ("lincat:"<+>c<+>"is a fun, not a cat")
-}
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js
_ -> return $ updateTree i js
-- | General Principle: only Just-values are checked.

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

@@ -1,365 +1,351 @@
-- | Translate concrete syntax to Haskell
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
import Data.List(sort,sortBy)
import Data.Function(on)
import Data.List(isPrefixOf,sort,sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Data.Utilities(mapSnd)
import GF.Text.Pretty
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
--import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
import GF.Infra.Option
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Haskell
import Debug.Trace
import GF.Haskell as H
import GF.Grammar.Canonical as C
import GF.Compile.GrammarToCanonical
import Debug.Trace(trace)
-- | Generate Haskell code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2haskell opts absname gr =
[(cncname,concrete2haskell opts gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
let cncname = render cnc ++ ".hs" :: FilePath
Ok cncmod = lookupModule gr cnc
[(filename,render80 $ concrete2haskell opts abstr cncmod)
| let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs,
let ModId name = concName cncmod
filename = name ++ ".hs" :: FilePath
]
-- | Generate Haskell code for the given concrete module.
-- The only options that make a difference are
-- @-haskell=noprefix@ and @-haskell=variants@.
concrete2haskell opts gr cenv absname cnc modinfo =
renderStyle style{lineLength=80,ribbonsPerLine=1} $
haskPreamble va absname cnc $$ vcat (
nl:Comment "--- Parameter types ---":
neededParamTypes S.empty (params defs) ++
nl:Comment "--- Type signatures for linearization functions ---":
map signature (S.toList allcats)++
nl:Comment "--- Linearization functions for empty categories ---":
emptydefs ++
nl:Comment "--- Linearization types and linearization functions ---":
map ppDef defs ++
nl:Comment "--- Type classes for projection functions ---":
map labelClass (S.toList labels) ++
nl:Comment "--- Record types ---":
concatMap recordType recs)
concrete2haskell opts
abstr@(Abstract _ _ cats funs)
modinfo@(Concrete cnc absname _ ps lcs lns) =
haskPreamble absname cnc $$
vcat (
nl:Comment "--- Parameter types ---":
map paramDef ps ++
nl:Comment "--- Type signatures for linearization functions ---":
map signature cats ++
nl:Comment "--- Linearization functions for empty categories ---":
emptydefs ++
nl:Comment "--- Linearization types ---":
map lincatDef lcs ++
nl:Comment "--- Linearization functions ---":
lindefs ++
nl:Comment "--- Type classes for projection functions ---":
map labelClass (S.toList labels) ++
nl:Comment "--- Record types ---":
concatMap recordType recs)
where
nl = Comment ""
recs = S.toList (S.difference (records (lcs,lns)) common_records)
labels = S.difference (S.unions (map S.fromList recs)) common_labels
recs = S.toList (S.difference (records rhss) common_records)
common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s]
label_s = ident2label (identS "s")
label_s = LabelId "s"
rhss = map (either snd (snd.snd)) defs
defs = sortBy (compare `on` either (const Nothing) (Just . fst)) .
concatMap (toHaskell gId gr absname cenv) .
M.toList $
jments modinfo
-- signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
-- signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c
signature c = TypeSig lf (Fun abs (pure lin))
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where
abs = tcon0 (prefixIdent "A." (gId c))
lin = tcon0 lc
lf = prefixIdent "lin" c
lc = prefixIdent "Lin" c
lf = linfunName c
lc = lincatName c
emptydefs = map emptydef (S.toList emptyCats)
emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined")
emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
emptyCats = allcats `S.difference` cats
cats = S.fromList [c|Right (c,_)<-defs]
allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
emptyCats = allcats `S.difference` linfuncats
where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent
params = S.toList . S.unions . map params1
params1 (Left (_,rhs)) = paramTypes gr rhs
params1 (Right (_,(_,rhs))) = tableTypes gr [rhs]
ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs)
ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs)
gId :: Ident -> Ident
gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G"
va = haskellOption opts HaskellVariants
pure = if va then ListT else id
neededParamTypes have [] = []
neededParamTypes have (q:qs) =
if q `S.member` have
then neededParamTypes have qs
else let ((got,need),def) = paramType va gId gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
haskPreamble va absname cncname =
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
"module" <+> cncname <+> "where" $$
"import Prelude hiding (Ordering(..))" $$
"import Control.Applicative((<$>),(<*>))" $$
"import PGF.Haskell" $$
"import qualified" <+> absname <+> "as A" $$
"" $$
"--- Standard definitions ---" $$
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
"" $$
"----------------------------------------------------" $$
"-- Automatic translation from GF to Haskell follows" $$
"----------------------------------------------------"
where
pure = if va then brackets else pp
toHaskell gId gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
[Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)]
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
-- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
[Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))]
haskPreamble :: ModId -> ModId -> Doc
haskPreamble absname cncname =
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
"module" <+> cncname <+> "where" $$
"import Prelude hiding (Ordering(..))" $$
"import Control.Applicative((<$>),(<*>))" $$
"import PGF.Haskell" $$
"import qualified" <+> absname <+> "as A" $$
"" $$
"--- Standard definitions ---" $$
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
"" $$
"----------------------------------------------------" $$
"-- Automatic translation from GF to Haskell follows" $$
"----------------------------------------------------"
where
Ok abstype = lookupFunType gr absname name
(absctx,_abscat,_absargs) = typeForm abstype
pure = if va then brackets else pp
e' = unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
args = map snd params
abs_args = map (prefixIdent "abs_") args
lhs = [ConP (aId name) (map VarP abs_args)]
rhs = foldr letlin e' (zip args absctx)
letlin (a,(_,_,at)) =
Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a)))))
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment)
_ -> []
_ -> []
where
nf loc = normalForm cenv (L loc name)
aId n = prefixIdent "A." (gId n)
paramDef pd =
case pd of
ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
where
paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
derive = ["Eq","Ord","Show"]
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
convLinType = ppT
where
ppT t =
case t of
FloatType -> tcon0 (identS "Float")
IntType -> tcon0 (identS "Int")
ParamType (ParamTypeId p) -> tcon0 (gId p)
RecordType rs -> tcon (rcon' ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
linfuncats = S.fromList linfuncatl
(linfuncatl,lindefs) = unzip (linDefs lns)
linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs)))
where
lhs = [ConP (aId f) (map VarP abs_args)]
aId f = prefixIdent "A." (gId f)
[lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
abs_args = map abs_arg args
abs_arg = prefixIdent "abs_"
args = map (prefixIdent "g" . toIdent) xs
rhs = lets (zipWith letlin args absctx)
(convert vs (coerce env lincat rhs0))
where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
where
[lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
convert = convert' va
convert' va vs = ppT
where
ppT0 = convert' False vs
ppTv vs' = convert' va vs'
pure = if va then single else id
ppT t =
case t of
TableValue ty cs -> pure (table cs)
Selection t p -> select (ppT t) (ppT p)
ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
RecordValue r -> aps (rcon ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
PredefValue p -> single (Var (toIdent p)) -- hmm
Projection t l -> ap (proj l) (ppT t)
VariantValue [] -> empty
VariantValue ts@(_:_) -> variants ts
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
PreValue vs t' -> pure (alts t' vs)
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
LiteralValue l -> ppL l
_ -> error ("convert "++show t)
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
else LambdaCase (map ppCase cs)
where
(ds,ts') = dedup ts
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
{-
ppPredef n =
case predef n of
Ok BIND -> single (c "BIND")
Ok SOFT_BIND -> single (c "SOFT_BIND")
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
Ok CAPIT -> single (c "CAPIT")
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
_ -> Var n
-}
ppP p =
case p of
ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
RecordPattern r -> ConP (rcon' ls) (map ppP ps)
where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
WildPattern -> WildP
token s = single (c "TK" `Ap` lit s)
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
where
alt (s,t) = Pair (List (pre s)) (ppT0 t)
pre s = map lit s
c = Const
lit s = c (show s) -- hmm
concat = if va then concat' else plusplus
where
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
concat' t1 t2 = Op t1 "+++" t2
pure' = single -- forcing the list monad
select = if va then select' else Ap
select' (List [t]) (List [p]) = Op t "!" p
select' (List [t]) p = Op t "!$" p
select' t p = Op t "!*" p
ap = if va then ap' else Ap
where
ap' (List [f]) x = fmap f x
ap' f x = Op f "<*>" x
fmap f (List [x]) = pure' (Ap f x)
fmap f x = Op f "<$>" x
-- join = if va then join' else id
join' (List [x]) = x
join' x = c "concat" `Ap` x
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
variants = if va then \ ts -> join' (List (map ppT ts))
else \ (t:_) -> ppT t
aps f [] = f
aps f (a:as) = aps (ap f a) as
dedup ts =
if M.null dups
then ([],map ppT ts)
else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
where
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
ev i = identS ("e'"++show i)
defs = [(i1,t)|(t,i1:_:_)<-ms]
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
ms = M.toList m
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
is = [0..]::[Int]
con = Cn . identS
--con = Cn . identS
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
case t of
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
class Records t where
records :: t -> S.Set [LabelId]
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
Sort _ -> S.empty
EInt _ -> S.empty
Q q -> lookup q
QC q -> lookup q
FV ts -> S.unions (map (paramTypes gr) ts)
_ -> ignore
where
lookup q = case lookupOrigInfo gr q of
Ok (_,ResOper _ (Just (L _ t))) ->
S.insert q (paramTypes gr t)
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
instance Records t => Records [t] where
records = S.unions . map records
ignore = trace ("Ignore: "++show t) S.empty
records ts = S.unions (map recs ts)
where
recs t =
case t of
R r -> S.insert (labels r) (records (map (snd.snd) r))
RecType r -> S.insert (labels r) (records (map snd r))
_ -> collectOp recs t
labels = sort . filter (not . isLockLabel) . map fst
instance (Records t1,Records t2) => Records (t1,t2) where
records (t1,t2) = S.union (records t1) (records t2)
instance Records LincatDef where
records (LincatDef _ lt) = records lt
instance Records LinDef where
records (LinDef _ _ lv) = records lv
instance Records LinType where
records t =
case t of
RecordType r -> rowRecords r
TableType pt lt -> records (pt,lt)
TupleType ts -> records ts
_ -> S.empty
rowRecords r = S.insert (sort ls) (records ts)
where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
instance Records LinValue where
records v =
case v of
ConcatValue v1 v2 -> records (v1,v2)
ParamConstant (Param c vs) -> records vs
RecordValue r -> rowRecords r
TableValue t r -> records (t,r)
TupleValue vs -> records vs
VariantValue vs -> records vs
PreValue alts d -> records (map snd alts,d)
Projection v l -> records v
Selection v1 v2 -> records (v1,v2)
_ -> S.empty
instance Records rhs => Records (TableRow rhs) where
records (TableRow _ v) = records v
-- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t =
case (ty,t) of
(_,Let d t) -> Let d (coerce (extend env d) ty t)
(_,FV ts) -> FV (map (coerce env ty) ts)
(Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
(Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
(RecType rt,R r) ->
R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
(RecType rt,Vr x)->
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
(RecordType rt,VarValue x)->
case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
--trace ("coerce "++render ty'++" to "++render ty) $
App (to_rcon (map fst rt)) t
_ -> trace ("no coerce to "++render ty) t
--trace ("coerce "++render ty'++" to "++render ty) $
app (to_rcon rt) [t]
| otherwise -> t -- types match, no coercion needed
_ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
$$ "in" <+> map fst env))
t
_ -> t
where
extend env (x,(Just ty,rhs)) = (x,ty):env
extend env _ = env
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . Unqual . to_rcon' . labels
convert va gId gr = convert' va gId [] gr
patVars p = []
convert' va gId vs gr = ppT
where
ppT0 = convert' False gId vs gr
ppTv vs' = convert' va gId vs' gr
labels r = [l|RecordRow l _<-r]
ppT t =
case t of
-- Only for 'let' inserted on the top-level by this converter:
Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t)
-- Abs b x t -> ...
V ty ts -> pure (c "table" `Ap` dedup ts)
T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs))
S t p -> select (ppT t) (ppT p)
C t1 t2 -> concat (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
R r -> aps (ppT (rcon (map fst r))) (fields r)
P t l -> ap (ppT (proj l)) (ppT t)
FV [] -> empty
Vr x -> if x `elem` vs then pure (Var x) else Var x
Cn x -> pure (Var x)
Con c -> pure (Var (gId c))
Sort k -> pure (Var k)
EInt n -> pure (lit n)
Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n)
QC (m,n) -> pure (Var (gId (qual m n)))
K s -> pure (token s)
Empty -> pure (List [])
FV ts@(_:_) -> variants ts
Alts t' vs -> pure (alts t' vs)
ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t)
ppPredef n =
case predef n of
Ok BIND -> single (c "BIND")
Ok SOFT_BIND -> single (c "SOFT_BIND")
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
Ok CAPIT -> single (c "CAPIT")
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
_ -> Var n
ppP p =
case p of
PC c ps -> ConP (gId c) (map ppP ps)
PP (_,c) ps -> ConP (gId c) (map ppP ps)
PR r -> ConP (rcon' (map fst r)) (map (ppP.snd) (filter (not.isLockLabel.fst) r))
PW -> WildP
PV x -> VarP x
PString s -> Lit (show s) -- !!
PInt i -> Lit (show i)
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p)
token s = single (c "TK" `Ap` lit s)
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
where
alt (t,p) = Pair (List (pre p)) (ppT0 t)
pre (K s) = [lit s]
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
pre t = error $ "pre "++show t
pat (PString s) = [lit s]
pat (PAlt p1 p2) = pat p1++pat p2
pat p = error $ "pat "++show p
fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst)
c = Const
lit s = c (show s) -- hmm
concat = if va then concat' else plusplus
where
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
concat' t1 t2 = Op t1 "+++" t2
pure = if va then single else id
pure' = single -- forcing the list monad
select = if va then select' else Ap
select' (List [t]) (List [p]) = Op t "!" p
select' (List [t]) p = Op t "!$" p
select' t p = Op t "!*" p
ap = if va then ap' else Ap
where
ap' (List [f]) x = fmap f x
ap' f x = Op f "<*>" x
fmap f (List [x]) = pure' (Ap f x)
fmap f x = Op f "<$>" x
-- join = if va then join' else id
join' (List [x]) = x
join' x = c "concat" `Ap` x
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
variants = if va then \ ts -> join' (List (map ppT ts))
else \ (t:_) -> ppT t
aps f [] = f
aps f (a:as) = aps (ap f a) as
dedup ts =
if M.null dups
then List (map ppT ts)
else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
where
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
ev i = identS ("e'"++show i)
defs = [(i1,t)|(t,i1:_:_)<-ms]
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
ms = M.toList m
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
is = [0..]::[Int]
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
convType va gId = ppT
where
ppT t =
case t of
Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv)
RecType rt -> tcon (rcon' (map fst rt)) (fields rt)
App tf ta -> TAp (ppT tf) (ppT ta)
FV [] -> tcon0 (identS "({-empty variant-})")
Sort k -> tcon0 k
EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> tcon0 (gId (qual m n))
Q (m,n) -> tcon0 (gId (qual m n))
_ -> error $ "Missing case in convType for: "++show t
fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst)
proj = con . proj'
proj' l = "proj_"++render l
rcon = con . rcon_name
proj = Var . identS . proj'
proj' (LabelId l) = "proj_"++l
rcon = Var . rcon'
rcon' = identS . rcon_name
rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
to_rcon = con . to_rcon'
rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
to_rcon' = ("to_"++) . rcon_name
recordType ls =
@@ -400,31 +386,6 @@ labelClass l =
r = identS "r"
a = identS "a"
paramType va gId gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
((S.singleton (m,n),argTypes ps),
[Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"],
Instance [] (TId (identS "EnumAll") `TAp` TId name)
[(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]]
)
where name = gId (qual m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.singleton (m,n),S.empty),
[Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[Type (conap0 (gId (qual m n))) (convType va gId t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = ConAp (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
enumParam m (n,ctx) = enumCon (gId (qual m n)) (length ctx)
enumCon name arity =
if arity==0
then single (Var name)
@@ -433,5 +394,23 @@ enumCon name arity =
ap (List [f]) a = Op f "<$>" a
ap f a = Op f "<*>" a
qual :: ModuleName -> Ident -> Ident
qual m = prefixIdent (render m++"_")
lincatName,linfunName :: CatId -> Ident
lincatName c = prefixIdent "Lin" (toIdent c)
linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
instance ToIdent PredefId where toIdent (PredefId s) = identS s
instance ToIdent CatId where toIdent (CatId s) = identS s
instance ToIdent C.FunId where toIdent (FunId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
qIdentS = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n
unqual (Unqual n) = n
instance ToIdent VarId where
toIdent Anonymous = identW
toIdent (VarId s) = identS s

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

@@ -1,11 +1,10 @@
module GF.Compile.Export where
import PGF
import PGF2
import GF.Compile.PGFtoHaskell
--import GF.Compile.PGFtoAbstract
import GF.Compile.PGFtoJava
import GF.Compile.PGFtoProlog
import GF.Compile.PGFtoJS
import GF.Compile.PGFtoPython
import GF.Compile.PGFtoJSON
import GF.Infra.Option
--import GF.Speech.CFG
import GF.Speech.PGFToCFG
@@ -19,6 +18,7 @@ import GF.Speech.SLF
import GF.Speech.PrRegExp
import Data.Maybe
import qualified Data.Map as Map
import System.FilePath
import GF.Text.Pretty
@@ -33,11 +33,11 @@ exportPGF :: Options
exportPGF opts fmt pgf =
case fmt of
FmtPGFPretty -> multi "txt" (showPGF)
FmtJavaScript -> multi "js" pgf2js
FmtPython -> multi "py" pgf2python
FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical)
FmtCanonicalJson-> []
FmtJSON -> multi "json" pgf2json
FmtHaskell -> multi "hs" (grammar2haskell opts name)
FmtJava -> multi "java" (grammar2java opts name)
FmtProlog -> multi "pl" grammar2prolog
FmtBNF -> single "bnf" bnfPrinter
FmtEBNF -> single "ebnf" (ebnfPrinter opts)
FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts)
@@ -51,17 +51,13 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter
where
name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
name = fromMaybe (abstractName pgf) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
-- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this.
outputConcr :: PGF -> CId
outputConcr pgf = case languages pgf of
[] -> error "No concrete syntax."
cnc:_ -> cnc

389
src/compiler/GF/Compile/GrammarToCanonical.hs Normal file
View File

@@ -0,0 +1,389 @@
-- | Translate grammars to Canonical form
-- (a common intermediate representation to simplify export to other formats)
module GF.Compile.GrammarToCanonical(
grammar2canonical,abstract2canonical,concretes2canonical,
projection,selection
) where
import Data.List(nub,partition)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Text.Pretty
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
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 GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C
import Debug.Trace
-- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes
grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr))
-- | Generate Canonical code for the named abstract syntax
abstract2canonical absname gr =
Abstract (modId absname) (convFlags gr absname) cats funs
where
cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
funs = [FunDef (gId f) (convType ty) |
((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
adefs = allOrigInfos gr absname
convCtx = maybe [] (map convHypo . unLoc)
convHypo (bt,name,t) =
case typeForm t of
([],(_,cat),[]) -> gId cat -- !!
convType t =
case typeForm t of
(hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
where
bs = map convHypo' hyps
as = map convType args
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
Ok cncmod = lookupModule gr cnc
]
-- | Generate Canonical GF for the given concrete module.
concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs))
[lincat|(_,Left lincat)<-defs]
[lin|(_,Right lin)<-defs]
where
defs = concatMap (toCanonical gr absname cenv) .
M.toList $
jments modinfo
params = S.toList . S.unions . map fst
neededParamTypes have [] = []
neededParamTypes have (q:qs) =
if q `S.member` have
then neededParamTypes have qs
else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
toCanonical gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
[(pts,Left (LincatDef (gId name) (convType ntyp)))]
where
pts = paramTypes gr ntyp
ntyp = nf loc typ
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
[(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
where
tts = tableTypes gr [e']
e' = unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,x)|(b,x,_)<-ctx]
args = map snd params
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
_ -> []
_ -> []
where
nf loc = normalForm cenv (L loc name)
-- aId n = prefixIdent "A." (gId n)
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
case t of
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
Sort _ -> S.empty
EInt _ -> S.empty
Q q -> lookup q
QC q -> lookup q
FV ts -> S.unions (map (paramTypes gr) ts)
_ -> ignore
where
lookup q = case lookupOrigInfo gr q of
Ok (_,ResOper _ (Just (L _ t))) ->
S.insert q (paramTypes gr t)
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
ignore = trace ("Ignore: "++show t) S.empty
convert gr = convert' gr []
convert' gr vs = ppT
where
ppT0 = convert' gr vs
ppTv vs' = convert' gr vs'
ppT t =
case t of
-- Abs b x t -> ...
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
where
Ok pts = allParamValues gr ty
Ok ps = mapM term2patt pts
T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
S t p -> selection (ppT t) (ppT p)
C t1 t2 -> concatValue (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
R r -> RecordValue (fields r)
P t l -> projection (ppT t) (lblId l)
Vr x -> VarValue (gId x)
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant 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 "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' "++show t
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
ppPredef n =
case predef n of
Ok BIND -> p "BIND"
Ok SOFT_BIND -> p "SOFT_BIND"
Ok SOFT_SPACE -> p "SOFT_SPACE"
Ok CAPIT -> p "CAPIT"
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm
where
p = PredefValue . PredefId
ppP p =
case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
PR r -> RecordPattern (fields r) {-
PW -> WildPattern
PV x -> VarP x
PString s -> Lit (show s) -- !!
PInt i -> Lit (show i)
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p) -}
where
fields = map field . filter (not.isLockLabel.fst)
field (l,p) = RecordRow (lblId l) (ppP p)
-- patToParam p = case ppP p of ParamPattern pv -> pv
-- token s = single (c "TK" `Ap` lit s)
alts vs = PreValue (map alt vs)
where
alt (t,p) = (pre p,ppT0 t)
pre (K s) = [s]
pre Empty = [""] -- Empty == K ""
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
pre t = error $ "pre "++show t
pat (PString s) = [s]
pat (PAlt p1 p2) = pat p1++pat p2
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
pat p = error $ "pat "++show p
fields = map field . filter (not.isLockLabel.fst)
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
--c = Const
--c = VarValue . VarValueId
--lit s = c (show s) -- hmm
ap f a = case f of
ParamConstant (Param p ps) ->
ParamConstant (Param p (ps++[a]))
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
projection r l = maybe (Projection r l) id (proj r l)
proj r l =
case r of
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
[v] -> Just v
_ -> Nothing
_ -> Nothing
-- | Smart constructor for selections
selection t v =
-- Note: impossible cases can become possible after grammar transformation
case t of
TableValue tt r ->
case nub [rv|TableRow _ rv<-keep] of
[rv] -> rv
_ -> Selection (TableValue tt r') v
where
-- Don't introduce wildcard patterns, true to the canonical format,
-- annotate (or eliminate) rhs in impossible rows
r' = map trunc r
trunc r@(TableRow p e) = if mightMatchRow v r
then r
else TableRow p (impossible e)
{-
-- Creates smaller tables, but introduces wildcard patterns
r' = if null discard
then r
else keep++[TableRow WildPattern impossible]
-}
(keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v
impossible = CommentedValue "impossible"
mightMatchRow v (TableRow p _) =
case p of
WildPattern -> True
_ -> mightMatch v p
mightMatch v p =
case v of
ConcatValue _ _ -> False
ParamConstant (Param c1 pvs) ->
case p of
ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
and [mightMatch v p|(v,p)<-zip pvs pps]
_ -> False
RecordValue rv ->
case p of
RecordPattern rp ->
and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
_ -> False
_ -> True
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
convType = ppT
where
ppT t =
case t of
Table ti tv -> TableType (ppT ti) (ppT tv)
RecType rt -> RecordType (convFields rt)
-- App tf ta -> TAp (ppT tf) (ppT ta)
-- FV [] -> tcon0 (identS "({-empty variant-})")
Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
_ -> error $ "Missing case in convType for: "++show t
convFields = map convField . filter (not.isLockLabel.fst)
convField (l,r) = RecordRow (lblId l) (ppT r)
convSort k = case showIdent k of
"Float" -> FloatType
"Int" -> IntType
"Str" -> StrType
_ -> error ("convSort "++show k)
toParamType t = case convType t of
ParamType pt -> pt
_ -> error ("toParamType "++show t)
toParamId t = case toParamType t of
ParamTypeId p -> p
paramType gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
where name = (gQId m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {-
((S.singleton (m,n),S.empty),
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)
class FromIdent i where gId :: Ident -> i
instance FromIdent VarId where
gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual m n = Qual (modId m) (showIdent n)
unqual n = Unqual (showIdent n)
convFlags gr mn =
Flags [(n,convLit 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

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

@@ -1,12 +1,12 @@
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts #-}
{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
module GF.Compile.GrammarToPGF (grammar2PGF) where
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import GF.Compile.OptimizePGF
import PGF(CId,mkCId,Type,Hypo,Expr)
import PGF.Internal
import PGF2 hiding (mkType)
import PGF2.Internal
import GF.Grammar.Predef
import GF.Grammar.Grammar hiding (Production)
import qualified GF.Grammar.Lookup as Look
@@ -19,18 +19,22 @@ import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
import Data.Char
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
import Data.Maybe(fromMaybe)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map CId Double -> IO PGF
import GHC.Prim
import GHC.Base(getTag)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
cnc_infos <- getConcreteInfos gr am
return $
build (let gflags = if flag optSplitPGF opts
then [(mkCId "split", LStr "true")]
then [("split", LStr "true")]
else []
(an,abs) = mkAbstr am probs
cncs = map (mkConcr opts abs) cnc_infos
@@ -39,21 +43,21 @@ grammar2PGF opts gr am probs = do
cenv = resourceValues opts gr
aflags = err (const noOptions) mflags (lookupModule gr am)
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map CId Double -> (CId, B s AbstrInfo)
mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
where
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = [(mkCId f,x) | (f,x) <- optionsPGF aflags]
flags = optionsPGF aflags
toLogProb = realToFrac . negate . log
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, {-mkDef gr arity mdef,-} toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
funs = [(f', mkType [] ty, arity, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
let arity = mkArity ma mdef ty,
let f' = i2i f]
@@ -72,7 +76,10 @@ grammar2PGF opts gr am probs = do
mkConcr opts abs (cm,ex_seqs,cdefs) =
let cflags = err (const noOptions) mflags (lookupModule gr cm)
flags = [(mkCId f,x) | (f,x) <- optionsPGF cflags]
ciCmp | flag optCaseSensitive cflags = compare
| otherwise = compareCaseInsensitive
flags = optionsPGF aflags
seqs = (mkSetArray . Set.fromList . concat) $
(elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
@@ -80,11 +87,11 @@ grammar2PGF opts gr am probs = do
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
= genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt1 cnccat_ranges
= genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
printnames = genPrintNames cdefs
startCat = mkCId (fromMaybe "S" (flag optStartCat aflags))
startCat = (fromMaybe "S" (flag optStartCat aflags))
(lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
(if flag optOptimizePGF opts then optimizePGF startCat else id)
@@ -118,16 +125,13 @@ grammar2PGF opts gr am probs = do
(seqs,infos) <- addMissingPMCFGs cm seqs is
return (seqs, ((m,id), info) : infos)
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
mkMapArray map = array (0,Map.size map-1) [(k,v) | (v,k) <- Map.toList map]
i2i :: Ident -> String
i2i = showIdent
i2i :: Ident -> CId
i2i = mkCId . showIdent
mi2i :: ModuleName -> CId
mi2i :: ModuleName -> String
mi2i (MN i) = i2i i
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF.Type
mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
mkType scope t =
case GM.typeForm t of
(hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
@@ -164,7 +168,7 @@ mkPatt scope p =
in (scope',C.PImplArg p')
A.PTilde t -> ( scope,C.PTilde (mkExp scope t))
-}
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF.Hypo])
mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW
then ( scope,hypo bt (i2i x) ty')
@@ -206,16 +210,17 @@ genCncFuns :: Grammar
-> ModuleName
-> ModuleName
-> Array SeqId [Symbol]
-> ([Symbol] -> [Symbol] -> Ordering)
-> Array SeqId [Symbol]
-> [(QIdent, Info)]
-> FId
-> Map.Map CId (Int,Int)
-> Map.Map PGF2.Cat (Int,Int)
-> (FId,
[(FId, [Production])],
[(FId, [FunId])],
[(FId, [FunId])],
[(CId,[SeqId])])
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
[(PGF2.Fun,[SeqId])])
genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty
(fid_cnt2,funs_cnt2,funs2,prods0) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
prods = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
@@ -304,7 +309,7 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccat_ranges =
newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
binSearch v arr (i,j)
| i <= j = case compare v (arr ! k) of
| i <= j = case ciCmp v (arr ! k) of
LT -> binSearch v arr (i,k-1)
EQ -> k
GT -> binSearch v arr (k+1,j)
@@ -323,3 +328,121 @@ genPrintNames cdefs =
flatten (K s) = s
flatten (Alts x _) = flatten x
flatten (C x y) = flatten x +++ flatten y
mkArray lst = listArray (0,length lst-1) lst
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
-- The following is a version of Data.List.sortBy which together
-- with the sorting also eliminates duplicate values
sortNubBy cmp = mergeAll . sequences
where
sequences (a:b:xs) =
case cmp a b of
GT -> descending b [a] xs
EQ -> sequences (b:xs)
LT -> ascending b (a:) xs
sequences xs = [xs]
descending a as [] = [a:as]
descending a as (b:bs) =
case cmp a b of
GT -> descending b (a:as) bs
EQ -> descending a as bs
LT -> (a:as) : sequences (b:bs)
ascending a as [] = let !x = as [a]
in [x]
ascending a as (b:bs) =
case cmp a b of
GT -> let !x = as [a]
in x : sequences (b:bs)
EQ -> ascending a as bs
LT -> ascending b (\ys -> as (a:ys)) bs
mergeAll [x] = x
mergeAll xs = mergeAll (mergePairs xs)
mergePairs (a:b:xs) = let !x = merge a b
in x : mergePairs xs
mergePairs xs = xs
merge as@(a:as') bs@(b:bs') =
case cmp a b of
GT -> b:merge as bs'
EQ -> a:merge as' bs'
LT -> a:merge as' bs
merge [] bs = bs
merge as [] = as
-- The following function does case-insensitive comparison of sequences.
-- This is used to allow case-insensitive parsing, while
-- the linearizer still has access to the original cases.
compareCaseInsensitive [] [] = EQ
compareCaseInsensitive [] _ = LT
compareCaseInsensitive _ [] = GT
compareCaseInsensitive (x:xs) (y:ys) =
case compareSym x y of
EQ -> compareCaseInsensitive xs ys
x -> x
where
compareSym s1 s2 =
case s1 of
SymCat d1 r1
-> case s2 of
SymCat d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymLit d1 r1
-> case s2 of
SymCat {} -> GT
SymLit d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> LT
SymVar d1 r1
-> if tagToEnum# (getTag s2 ># 2#)
then LT
else case s2 of
SymVar d2 r2
-> case compare d1 d2 of
EQ -> r1 `compare` r2
x -> x
_ -> GT
SymKS t1
-> if tagToEnum# (getTag s2 ># 3#)
then LT
else case s2 of
SymKS t2 -> t1 `compareToken` t2
_ -> GT
SymKP a1 b1
-> if tagToEnum# (getTag s2 ># 4#)
then LT
else case s2 of
SymKP a2 b2
-> case compare a1 a2 of
EQ -> b1 `compare` b2
x -> x
_ -> GT
_ -> let t1 = getTag s1
t2 = getTag s2
in if tagToEnum# (t1 <# t2)
then LT
else if tagToEnum# (t1 ==# t2)
then EQ
else GT
compareToken [] [] = EQ
compareToken [] _ = LT
compareToken _ [] = GT
compareToken (x:xs) (y:ys)
| x == y = compareToken xs ys
| otherwise = case compare (toLower x) (toLower y) of
EQ -> case compareToken xs ys of
EQ -> compare x y
x -> x
x -> x

88
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -1,88 +0,0 @@
module GF.Compile.PGFtoJS (pgf2js) where
import PGF
import PGF.Internal
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
pgf2js :: PGF -> String
pgf2js pgf =
JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = showCId $ abstractName pgf
start = showType [] $ startCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start pgf
js_concrete = JS.EObj $ map (concrete2js pgf) (languages pgf)
abstract2js :: String -> PGF -> JS.Expr
abstract2js start pgf = new "GFAbstract" [JS.EStr start, JS.EObj [absdef2js f ty | f <- functions pgf, Just ty <- [functionType pgf f]]]
absdef2js :: CId -> Type -> JS.Property
absdef2js f typ =
let (hypos,cat,_) = unType typ
args = [cat | (_,_,typ) <- hypos, let (hypos,cat,_) = unType typ]
in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
lit2js (LStr s) = JS.EStr s
lit2js (LInt n) = JS.EInt n
lit2js (LFlt d) = JS.EDbl d
concrete2js :: PGF -> Language -> JS.Property
concrete2js pgf lang =
JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ concrFlags cnc,
JS.EObj [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (concrProductions cnc cat))) | cat <- [0..concrTotalCats cnc]],
JS.EArray [ffun2js (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc]],
JS.EArray [seq2js (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc]],
JS.EObj $ map cats (concrCategories cnc),
JS.EInt (concrTotalCats cnc)])
where
cnc = lookConcr pgf lang
l = JS.IdentPropName (JS.Ident (showCId lang))
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cats (c,start,end,_) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
children :: JS.Ident
children = JS.Ident "cs"
frule2js :: Production -> JS.Expr
frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)]
frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
ffun2js (f,lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt lins)]
seq2js :: [Symbol] -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- seq]
sym2js :: Symbol -> JS.Expr
sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l]
sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l]
sym2js (SymKS t) = new "SymKS" [JS.EStr t]
sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)]
sym2js SymBIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_BIND = new "SymKS" [JS.EStr "&+"]
sym2js SymSOFT_SPACE = new "SymKS" [JS.EStr "&+"]
sym2js SymCAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymALL_CAPIT = new "SymKS" [JS.EStr "&|"]
sym2js SymNE = new "SymNE" []
alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs
mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]

156
src/compiler/GF/Compile/PGFtoJSON.hs Normal file
View File

@@ -0,0 +1,156 @@
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 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)))
]
absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
where
(args,cat) = M.catSkeleton typ
sig = JSON.makeObj
[ ("args", JSArray $ map (mkJSStr.showCId) args)
, ("cat", mkJSStr $ showCId cat)
]
lit2json :: Literal -> JSValue
lit2json (LStr s) = mkJSStr s
lit2json (LInt n) = mkJSInt n
lit2json (LFlt d) = JSRational True (toRational d)
concrete2json :: (CId,Concr) -> (String,JSValue)
concrete2json (c,cnc) = (showCId 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))
]
cats2json :: (CId, CncCat) -> (String,JSValue)
cats2json (c,CncCat start end _) = (showCId c, ixs)
where
ixs = JSON.makeObj
[ ("start", mkJSInt start)
, ("end", mkJSInt end)
]
frule2json :: Production -> JSValue
frule2json (PApply fid args) =
JSON.makeObj
[ ("type", mkJSStr "Apply")
, ("fid", mkJSInt fid)
, ("args", JSArray (map farg2json args))
]
frule2json (PCoerce arg) =
JSON.makeObj
[ ("type", mkJSStr "Coerce")
, ("arg", mkJSInt arg)
]
farg2json :: PArg -> JSValue
farg2json (PArg hypos fid) =
JSON.makeObj
[ ("type", mkJSStr "PArg")
, ("hypos", JSArray $ map (mkJSInt . snd) hypos)
, ("fid", mkJSInt fid)
]
ffun2json :: CncFun -> JSValue
ffun2json (CncFun f lins) =
JSON.makeObj
[ ("name", mkJSStr $ showCId f)
, ("lins", JSArray (map mkJSInt (Array.elems lins)))
]
seq2json :: Array.Array DotPos Symbol -> JSValue
seq2json seq = JSArray [sym2json s | s <- Array.elems 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 (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 SymNE = new "SymNE" []
alt2json :: ([Symbol],[String]) -> JSValue
alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
new :: String -> [JSValue] -> JSValue
new f xs =
JSON.makeObj
[ ("type", mkJSStr f)
, ("args", JSArray 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

186
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -1,186 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoProlog
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Prolog module
-----------------------------------------------------------------------------
module GF.Compile.PGFtoProlog (grammar2prolog) where
import PGF
import PGF.Internal
import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
import Data.List (isPrefixOf, mapAccumL)
grammar2prolog :: PGF -> String
grammar2prolog pgf
= ("%% This file was automatically generated by GF" +++++
":- style_check(-singleton)." +++++
plFacts wildCId "abstract" 1 "(?AbstractName)"
[[plp name]] ++++
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
[[plp name, plp cncname] |
cncname <- languages pgf] ++++
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
[[plp f, plp v] |
(f, v) <- Map.assocs (globalFlags pgf)] ++++
plAbstract name pgf ++++
unlines [plConcrete name (lookConcr pgf name) | name <- languages pgf]
)
where name = abstractName pgf
----------------------------------------------------------------------
-- abstract syntax
plAbstract :: CId -> PGF -> String
plAbstract name pgf
= (plHeader "Abstract syntax" ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (abstrFlags pgf)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat, []] | cat <- categories pgf] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat, plHypos hypos] |
fun <- functions pgf, Just typ <- [functionType pgf fun],
let (hypos,cat,_) = unType typ]
)
where plType cat = plTerm (plp cat) []
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
----------------------------------------------------------------------
-- concrete syntax
plConcrete :: CId -> Concr -> String
plConcrete name cnc
= (plHeader ("Concrete syntax: " ++ plp name) ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (concrFlags cnc)] ++++
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
[[plCat cat, fun, plTerm "c" (map plCat args)] |
cat <- [0..concrTotalCats cnc-1],
(fun, args) <- map plProduction (concrProductions cnc cat)] ++++
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
[[plFun funid, plTerm "s" (map plSeq lins), plp absfun] |
funid <- [0..concrTotalFuns cnc-1], let (absfun,lins) = concrFunction cnc funid] ++++
plFacts name "seq" 2 "(?Seq, ?[Term])"
[[plSeq seqid, plp (concrSequence cnc seqid)] |
seqid <- [0..concrTotalSeqs cnc-1]] ++++
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
[[plp cat, plList (map plCat [start..end])] |
(cat,start,end,_) <- concrCategories cnc]
)
where plProduction (PCoerce arg) = ("-", [arg])
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
----------------------------------------------------------------------
-- prolog-printing pgf datatypes
instance PLPrint Type where
plp ty
| null hypos = result
| otherwise = plOper " -> " plHypos result
where (hypos,cat,_) = unType ty
result = plTerm (plp cat) []
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
instance PLPrint CId where
plp cid | isLogicalVariable str || cid == wildCId = plVar str
| otherwise = plAtom str
where str = showCId cid
instance PLPrint Literal where
plp (LStr s) = plp s
plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f)
instance PLPrint Symbol where
plp (SymCat n l) = plOper ":" (show n) (show l)
plp (SymLit n l) = plTerm "lit" [show n, show l]
plp (SymVar n l) = plTerm "var" [show n, show l]
plp (SymKS t) = plAtom t
plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
class PLPrint a where
plp :: a -> String
plps :: [a] -> String
plps = plList . map plp
instance PLPrint Char where
plp c = plAtom [c]
plps s = plAtom s
instance PLPrint a => PLPrint [a] where
plp = plps
----------------------------------------------------------------------
-- other prolog-printing functions
plCat :: Int -> String
plCat n = plAtom ('c' : show n)
plFun :: Int -> String
plFun n = plAtom ('f' : show n)
plSeq :: Int -> String
plSeq n = plAtom ('s' : show n)
plHeader :: String -> String
plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
plFacts :: CId -> String -> Int -> String -> [[String]] -> String
plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
mod' = if mod == wildCId then "" else plp mod ++ ": "
plTerm :: String -> [String] -> String
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
plList :: [String] -> String
plList xs = prBracket (prTList "," xs)
plOper :: String -> String -> String -> String
plOper op a b = prParenth (a ++ op ++ b)
plVar :: String -> String
plVar = varPrefix . concatMap changeNonAlphaNum
where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
| otherwise = "_" ++ var
changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
| otherwise = "_" ++ show (ord c) ++ "_"
plAtom :: String -> String
plAtom "" = "''"
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|| c == '\'' && cs /= "" && last cs == '\'' = atom
| otherwise = "'" ++ changeQuote atom ++ "'"
where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
changeQuote (c:cs) = c : changeQuote cs
changeQuote "" = ""
isAlphaNumUnderscore :: Char -> Bool
isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
----------------------------------------------------------------------
-- prolog variables
createLogicalVariable :: Int -> CId
createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
isLogicalVariable :: String -> Bool
isLogicalVariable = isPrefixOf logicalVariablePrefix
logicalVariablePrefix :: String
logicalVariablePrefix = "X"

114
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -1,114 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module : PGFtoPython
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Python module
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Compile.PGFtoPython (pgf2python) where
import PGF
import PGF.Internal
import qualified Data.Map as Map
import GF.Data.Operations
pgf2python :: PGF -> String
pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
"# This file was automatically generated by GF" +++++
showCId name +++ "=" +++
pyDict 1 pyStr id [
("flags", pyDict 2 pyCId pyLiteral (Map.assocs (globalFlags pgf))),
("abstract", pyDict 2 pyStr id [
("name", pyCId name),
("start", pyCId start),
("flags", pyDict 3 pyCId pyLiteral (Map.assocs (abstrFlags pgf))),
("funs", pyDict 3 pyCId pyAbsdef [(f,ty) | f <- functions pgf, Just ty <- [functionType pgf f]])
]),
("concretes", pyDict 2 pyCId pyConcrete [(lang,lookConcr pgf lang) | lang <- languages pgf])
] ++ "\n")
where
name = abstractName pgf
(_,start,_) = unType (startCat pgf)
-- cncs = concretes pgf
pyAbsdef :: Type -> String
pyAbsdef typ = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (hypos,cat,_) = unType typ
args = [cat | (_,_,typ) <- hypos, let (_,cat,_) = unType typ]
pyLiteral :: Literal -> String
pyLiteral (LStr s) = pyStr s
pyLiteral (LInt n) = show n
pyLiteral (LFlt d) = show d
pyConcrete :: Concr -> String
pyConcrete cnc = pyDict 3 pyStr id [
("flags", pyDict 0 pyCId pyLiteral (Map.assocs (concrFlags cnc))),
("productions", pyDict 4 pyCat pyProds [(fid,concrProductions cnc fid) | fid <- [0..concrTotalCats cnc-1]]),
("cncfuns", pyDict 4 pyFun pyCncFun [(funid,concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]),
("sequences", pyDict 4 pySeq pySymbols [(seqid,concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]),
("cnccats", pyDict 4 pyCId pyCncCat [(cat,(s,e,lbls)) | (cat,s,e,lbls) <- concrCategories cnc]),
("size", show (concrTotalCats cnc))
]
where pyProds prods = pyList 5 pyProduction prods
pyCncCat (start,end,_) = pyList 0 pyCat [start..end]
pyCncFun (f,lins) = pyTuple 0 id [pyList 0 pySeq lins, pyCId f]
pySymbols syms = pyList 0 pySymbol syms
pyProduction :: Production -> String
pyProduction (PCoerce arg) = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]
pyProduction (PApply funid args) = pyTuple 0 id [pyFun funid, pyList 0 pyPArg args]
where pyPArg (PArg [] fid) = pyCat fid
pyPArg (PArg hypos fid) = pyTuple 0 pyCat (fid : map snd hypos)
pySymbol :: Symbol -> String
pySymbol (SymCat n l) = pyTuple 0 show [n, l]
pySymbol (SymLit n l) = pyDict 0 pyStr id [("lit", pyTuple 0 show [n, l])]
pySymbol (SymVar n l) = pyDict 0 pyStr id [("var", pyTuple 0 show [n, l])]
pySymbol (SymKS t) = pyStr t
pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pySymbol ts), ("alts", pyList 0 alt2py alts)]
where alt2py (ps,ts) = pyTuple 0 (pyList 0 pyStr) [map pySymbol ps, ts]
pySymbol SymBIND = pyStr "&+"
pySymbol SymSOFT_BIND = pyStr "&+"
pySymbol SymSOFT_SPACE = pyStr "&+"
pySymbol SymCAPIT = pyStr "&|"
pySymbol SymALL_CAPIT = pyStr "&|"
pySymbol SymNE = pyDict 0 pyStr id [("nonExist", pyTuple 0 id [])]
----------------------------------------------------------------------
-- python helpers
pyDict :: Int -> (k -> String) -> (v -> String) -> [(k, v)] -> String
pyDict n pk pv [] = "{}"
pyDict n pk pv kvlist = prCurly (pyIndent n ++ prTList ("," ++ pyIndent n) (map pyKV kvlist) ++ pyIndent n)
where pyKV (k, v) = pk k ++ ":" ++ pv v
pyList :: Int -> (v -> String) -> [v] -> String
pyList n pv [] = "[]"
pyList n pv xs = prBracket (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyTuple :: Int -> (v -> String) -> [v] -> String
pyTuple n pv [] = "()"
pyTuple n pv [x] = prParenth (pyIndent n ++ pv x ++ "," ++ pyIndent n)
pyTuple n pv xs = prParenth (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
pyCat :: Int -> String
pyCat n = pyStr ('C' : show n)
pyFun :: Int -> String
pyFun n = pyStr ('F' : show n)
pySeq :: Int -> String
pySeq n = pyStr ('S' : show n)
pyStr :: String -> String
pyStr s = 'u' : prQuotedString s
pyCId :: CId -> String
pyCId = pyStr . showCId
pyIndent :: Int -> String
pyIndent n | n > 0 = "\n" ++ replicate n ' '
| otherwise = ""

11
src/compiler/GF/Compile/TypeCheck/RConcrete.hs
View File

@@ -359,12 +359,13 @@ getOverload gr g mt ot = case appForm ot of
nest 2 (showTypes pre)
return (mkApp fun tts, val)
([],[]) -> do
checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
"for" $$
checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
maybe empty (\x -> "with value type" <+> ppType x) mt $$
"for argument list" $$
nest 2 stysError $$
"among" $$
nest 2 (vcat stypsError) $$
maybe empty (\x -> "with value type" <+> ppType x) mt
"among alternatives" $$
nest 2 (vcat stypsError)
(vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
([(val,fun)],_) -> do

232
src/compiler/GF/Compile/pgf.schema.json Normal file
View File

@@ -0,0 +1,232 @@
{
"$schema": "http://json-schema.org/draft-07/schema#",
"$id": "http://grammaticalframework.org/pgf.schema.json",
"type": "object",
"title": "PGF JSON Schema",
"required": [
"abstract",
"concretes"
],
"properties": {
"abstract": {
"type": "object",
"required": [
"name",
"startcat",
"funs"
],
"properties": {
"name": {
"type": "string"
},
"startcat": {
"type": "string"
},
"funs": {
"type": "object",
"additionalProperties": {
"type": "object",
"required": [
"args",
"cat"
],
"properties": {
"args": {
"type": "array",
"items": {
"type": "string"
}
},
"cat": {
"type": "string"
}
}
}
}
}
},
"concretes": {
"type": "object",
"additionalProperties": {
"required": [
"flags",
"productions",
"functions",
"sequences",
"categories",
"totalfids"
],
"properties": {
"flags": {
"type": "object",
"additionalProperties": {
"type": ["string", "number"]
}
},
"productions": {
"type": "object",
"additionalProperties": {
"type": "array",
"items": {
"oneOf": [
{
"$ref": "#/definitions/apply"
},
{
"$ref": "#/definitions/coerce"
}
]
}
}
},
"functions": {
"type": "array",
"items": {
"title": "CncFun",
"type": "object",
"properties": {
"name": {
"type": "string"
},
"lins": {
"type": "array",
"items": {
"type": "integer"
}
}
}
}
},
"sequences": {
"type": "array",
"items": {
"type": "array",
"items": {
"$ref": "#/definitions/sym"
}
}
},
"categories": {
"type": "object",
"additionalProperties": {
"title": "CncCat",
"type": "object",
"required": [
"start",
"end"
],
"properties": {
"start": {
"type": "integer"
},
"end": {
"type": "integer"
}
}
}
},
"totalfids": {
"type": "integer"
}
}
}
}
},
"definitions": {
"apply": {
"required": [
"type",
"fid",
"args"
],
"properties": {
"type": {
"type": "string",
"enum": ["Apply"]
},
"fid": {
"type": "integer"
},
"args": {
"type": "array",
"items": {
"$ref": "#/definitions/parg"
}
}
}
},
"coerce": {
"required": [
"type",
"arg"
],
"properties": {
"type": {
"type": "string",
"enum": ["Coerce"]
},
"arg": {
"type": "integer"
}
}
},
"parg": {
"required": [
"type",
"hypos",
"fid"
],
"properties": {
"type": {
"type": "string",
"enum": ["PArg"]
},
"hypos": {
"type": "array",
"items": {
"type": "integer"
}
},
"fid": {
"type": "integer"
}
}
},
"sym": {
"title": "Sym",
"required": [
"type",
"args"
],
"properties": {
"type": {
"type": "string",
"enum": [
"SymCat",
"SymLit",
"SymVar",
"SymKS",
"SymKP",
"SymNE"
]
},
"args": {
"type": "array",
"items": {
"anyOf": [
{
"type": "string"
},
{
"type": "integer"
},
{
"$ref": "#/definitions/sym"
}
]
}
}
}
}
}
}

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

@@ -1,11 +1,12 @@
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
import PGF
import PGF.Internal(unionPGF,writePGF,writeConcr)
import PGF2
import PGF2.Internal(unionPGF,writePGF,writeConcr)
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export
import GF.Compile.ConcreteToHaskell(concretes2haskell)
import GF.Compile.GrammarToCanonical--(concretes2canonical)
import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar
import GF.Grammar.BNFC
@@ -16,12 +17,13 @@ import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.ErrM
import GF.System.Directory
import GF.Text.Pretty(render)
import GF.Text.Pretty(render,render80)
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BSL
import GF.Grammar.CanonicalJSON (encodeJSON)
import System.FilePath
import Control.Monad(when,unless,forM_)
@@ -46,7 +48,7 @@ mainGFC opts fs = do
compileSourceFiles :: Options -> [FilePath] -> IOE ()
compileSourceFiles opts fs =
do output <- batchCompile opts fs
cncs2haskell output
exportCanonical output
unless (flag optStopAfterPhase opts == Compile) $
linkGrammars opts output
where
@@ -54,15 +56,35 @@ compileSourceFiles opts fs =
batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
return (t,[cnc_gr])
cncs2haskell output =
when (FmtHaskell `elem` flag optOutputFormats opts &&
haskellOption opts HaskellConcrete) $
mapM_ cnc2haskell (snd output)
exportCanonical (_time, canonical) =
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
mapM_ cnc2haskell canonical
when (FmtCanonicalGF `elem` ofmts) $
do createDirectoryIfMissing False "canonical"
mapM_ abs2canonical canonical
mapM_ cnc2canonical canonical
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
where
ofmts = flag optOutputFormats opts
cnc2haskell (cnc,gr) =
mapM_ writeHs $ concretes2haskell opts (srcAbsName gr cnc) gr
do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
writeHs (path,s) = writing opts path $ writeUTF8File path s
abs2canonical (cnc,gr) =
writeExport ("canonical/"++render absname++".gf",render80 canAbs)
where
absname = srcAbsName gr cnc
canAbs = abstract2canonical absname gr
cnc2canonical (cnc,gr) =
mapM_ (writeExport.fmap render80) $
concretes2canonical opts (srcAbsName gr cnc) gr
grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
where absname = srcAbsName gr cnc
gr_canon = grammar2canonical opts absname gr
writeExport (path,s) = writing opts path $ writeUTF8File path s
-- | Create a @.pgf@ file (and possibly files in other formats, if specified
@@ -113,7 +135,7 @@ unionPGFFiles opts fs =
doIt =
do pgfs <- mapM readPGFVerbose fs
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
if pgfFile `elem` fs
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
else writeGrammar opts pgf
@@ -135,7 +157,7 @@ writeOutputs opts pgf = do
-- A split PGF file is output if the @-split-pgf@ option is used.
writeGrammar :: Options -> PGF -> IOE ()
writeGrammar opts pgf =
if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
where
writeNormalPGF =
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
@@ -144,9 +166,9 @@ writeGrammar opts pgf =
writeSplitPGF =
do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
writing opts outfile $ writePGF outfile pgf
forM_ (languages pgf) $ \lang -> do
let outfile = outputPath opts (showCId lang <.> "pgf_c")
writing opts outfile (writeConcr outfile pgf lang)
forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
let outfile = outputPath opts (concrname <.> "pgf_c")
writing opts outfile (writeConcr outfile concr)
writeOutput :: Options -> FilePath-> String -> IOE ()
@@ -156,7 +178,7 @@ writeOutput opts file str = writing opts path $ writeUTF8File path str
-- * Useful helper functions
grammarName :: Options -> PGF -> String
grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
grammarName opts pgf = grammarName' opts (abstractName pgf)
grammarName' opts abs = fromMaybe abs (flag optName opts)
outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)

313
src/compiler/GF/Grammar/Canonical.hs Normal file
View File

@@ -0,0 +1,313 @@
-- |
-- Module : GF.Grammar.Canonical
-- Stability : provisional
--
-- Abstract syntax for canonical GF grammars, i.e. what's left after
-- high-level constructions such as functors and opers have been eliminated
-- by partial evaluation. This is intended as a common intermediate
-- representation to simplify export to other formats.
{-# LANGUAGE DeriveTraversable #-}
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
-- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show
--------------------------------------------------------------------------------
-- ** Abstract Syntax
-- | Abstract Syntax
data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
abstrName (Abstract mn _ _ _) = mn
data CatDef = CatDef CatId [CatId] deriving Show
data FunDef = FunDef FunId Type deriving Show
data Type = Type [TypeBinding] TypeApp deriving Show
data TypeApp = TypeApp CatId [Type] deriving Show
data TypeBinding = TypeBinding VarId Type deriving Show
--------------------------------------------------------------------------------
-- ** Concreate syntax
-- | Concrete Syntax
data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
deriving Show
concName (Concrete cnc _ _ _ _ _) = cnc
data ParamDef = ParamDef ParamId [ParamValueDef]
| ParamAliasDef ParamId LinType
deriving Show
data LincatDef = LincatDef CatId LinType deriving Show
data LinDef = LinDef FunId [VarId] LinValue deriving Show
-- | Linearization type, RHS of @lincat@
data LinType = FloatType
| IntType
| ParamType ParamType
| RecordType [RecordRowType]
| StrType
| TableType LinType LinType
| TupleType [LinType]
deriving (Eq,Ord,Show)
newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-- | Linearization value, RHS of @lin@
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| ErrorValue String
| ParamConstant ParamValue
| PredefValue PredefId
| RecordValue [RecordRowValue]
| TableValue LinType [TableRowValue]
--- | VTableValue LinType [LinValue]
| TupleValue [LinValue]
| VariantValue [LinValue]
| VarValue VarValueId
| PreValue [([String], LinValue)] LinValue
| Projection LinValue LabelId
| Selection 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]
| WildPattern
deriving (Eq,Ord,Show)
type ParamValue = Param LinValue
type ParamPattern = Param LinPattern
type ParamValueDef = Param ParamId
data Param arg = Param ParamId [arg]
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
type RecordRowType = RecordRow LinType
type RecordRowValue = RecordRow LinValue
type TableRowValue = TableRow LinValue
data RecordRow rhs = RecordRow LabelId rhs
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
data TableRow rhs = TableRow LinPattern rhs
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
-- *** Identifiers in Concrete Syntax
newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
-- | Name of param type or param value
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
newtype ModId = ModId Id deriving (Eq,Ord,Show)
newtype CatId = CatId Id deriving (Eq,Ord,Show)
newtype FunId = FunId Id deriving (Eq,Show)
data VarId = Anonymous | VarId Id deriving Show
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
type FlagName = Id
data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
type Id = String
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
-- ** Pretty printing
instance Pretty Grammar where
pp (Grammar abs cncs) = abs $+$ vcat cncs
instance Pretty Abstract where
pp (Abstract m flags cats funs) =
"abstract" <+> m <+> "=" <+> "{" $$
flags $$
"cat" <+> fsep cats $$
"fun" <+> vcat funs $$
"}"
instance Pretty CatDef where
pp (CatDef c cs) = hsep (c:cs)<>";"
instance Pretty FunDef where
pp (FunDef f ty) = f <+> ":" <+> ty <>";"
instance Pretty Type where
pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
instance PPA Type where
ppA (Type [] (TypeApp c [])) = pp c
ppA t = parens t
instance Pretty TypeBinding where
pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
pp (TypeBinding Anonymous ty) = parens ty
pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
instance Pretty TypeApp where
pp (TypeApp c targs) = c<+>hsep (map ppA targs)
instance Pretty VarId where
pp Anonymous = pp "_"
pp (VarId x) = pp x
--------------------------------------------------------------------------------
instance Pretty Concrete where
pp (Concrete cncid absid flags params lincats lins) =
"concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
vcat params $$
section "lincat" lincats $$
section "lin" lins $$
"}"
where
section name [] = empty
section name ds = name <+> vcat (map (<> ";") ds)
instance Pretty ParamDef where
pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
instance PPA arg => Pretty (Param arg) where
pp (Param p ps) = pp p<+>sep (map ppA ps)
instance PPA arg => PPA (Param arg) where
ppA (Param p []) = pp p
ppA pv = parens pv
instance Pretty LincatDef where
pp (LincatDef c lt) = hang (c <+> "=") 4 lt
instance Pretty LinType where
pp lt = case lt of
FloatType -> pp "Float"
IntType -> pp "Int"
ParamType pt -> pp pt
RecordType rs -> block rs
StrType -> pp "Str"
TableType pt lt -> sep [pt <+> "=>",pp lt]
TupleType lts -> "<"<>punctuate "," lts<>">"
instance RhsSeparator LinType where rhsSep _ = pp ":"
instance Pretty ParamType where
pp (ParamTypeId p) = pp p
instance Pretty LinDef where
pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
instance Pretty LinValue where
pp lv = case lv of
ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
ErrorValue s -> "Predef.error"<+>doubleQuotes s
ParamConstant pv -> pp pv
Projection lv l -> ppA lv<>"."<>l
Selection tv pv -> ppA tv<>"!"<>ppA pv
VariantValue vs -> "variants"<+>block vs
CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
_ -> ppA lv
instance PPA LinValue where
ppA lv = case lv of
LiteralValue l -> ppA l
ParamConstant pv -> ppA pv
PredefValue p -> ppA p
RecordValue [] -> pp "<>"
RecordValue rvs -> block rvs
PreValue alts def ->
"pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
where
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
2 ("=>"<+>lv)
TableValue _ tvs -> "table"<+>block tvs
-- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
TupleValue lvs -> "<"<>punctuate "," lvs<>">"
VarValue v -> pp v
_ -> parens lv
instance Pretty LinLiteral where pp = ppA
instance PPA LinLiteral where
ppA l = case l of
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "="
instance Pretty LinPattern where
pp p =
case p of
ParamPattern pv -> pp pv
_ -> ppA p
instance PPA LinPattern where
ppA p =
case p of
ParamPattern pv -> ppA pv
RecordPattern r -> block r
TuplePattern ps -> "<"<>punctuate "," ps<>">"
WildPattern -> pp "_"
_ -> parens p
instance RhsSeparator LinPattern where rhsSep _ = pp "="
instance RhsSeparator rhs => Pretty (RecordRow rhs) where
pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
instance Pretty rhs => Pretty (TableRow rhs) where
pp (TableRow l v) = hang (l<+>"=>") 2 v
--------------------------------------------------------------------------------
instance Pretty ModId where pp (ModId s) = pp s
instance Pretty CatId where pp (CatId s) = pp s
instance Pretty FunId where pp (FunId s) = pp s
instance Pretty LabelId where pp (LabelId s) = pp s
instance Pretty PredefId where pp = ppA
instance PPA PredefId where ppA (PredefId s) = "Predef."<>s
instance Pretty ParamId where pp = ppA
instance PPA ParamId where ppA (ParamId s) = pp s
instance Pretty VarValueId where pp (VarValueId s) = pp s
instance Pretty QualId where pp = ppA
instance PPA QualId where
ppA (Qual m n) = m<>"_"<>n -- hmm
ppA (Unqual n) = pp n
instance Pretty Flags where
pp (Flags []) = empty
pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
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
class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
semiSep xs = punctuate ";" xs
block xs = braces (semiSep xs)

289
src/compiler/GF/Grammar/CanonicalJSON.hs Normal file
View File

@@ -0,0 +1,289 @@
module GF.Grammar.CanonicalJSON (
encodeJSON
) where
import Text.JSON
import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
encodeJSON :: FilePath -> Grammar -> IO ()
encodeJSON fpath g = writeFile fpath (encode g)
-- in general we encode grammars using JSON objects/records,
-- except for newtypes/coercions/direct values
-- the top-level definitions use normal record labels,
-- but recursive types/values/ids use labels staring with a "."
instance JSON Grammar where
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
--------------------------------------------------------------------------------
-- ** Abstract Syntax
instance JSON Abstract where
showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid),
("flags", showJSON flags),
("cats", showJSON cats),
("funs", showJSON funs)]
readJSON o = Abstract
<$> o!"abs"
<*>(o!"flags" <|> return (Flags []))
<*> o!"cats"
<*> o!"funs"
instance JSON CatDef where
-- non-dependent categories are encoded as simple strings:
showJSON (CatDef c []) = showJSON c
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
readJSON o = CatDef <$> readJSON o <*> return []
<|> CatDef <$> o!"cat" <*> o!"args"
instance JSON FunDef where
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
readJSON o = FunDef <$> o!"fun" <*> o!"type"
instance JSON Type where
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
readJSON o = Type <$> o!".args" <*> o!".result"
instance JSON TypeApp where
-- non-dependent categories are encoded as simple strings:
showJSON (TypeApp c []) = showJSON c
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
readJSON o = TypeApp <$> readJSON o <*> return []
<|> TypeApp <$> o!".cat" <*> o!".args"
instance JSON TypeBinding where
-- non-dependent categories are encoded as simple strings:
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
readJSON o = do c <- readJSON o
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
<|> TypeBinding <$> o!".var" <*> o!".type"
--------------------------------------------------------------------------------
-- ** Concrete syntax
instance JSON Concrete where
showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid),
("abs", showJSON absid),
("flags", showJSON flags),
("params", showJSON params),
("lincats", showJSON lincats),
("lins", showJSON lins)]
readJSON o = Concrete
<$> o!"cnc"
<*> o!"abs"
<*>(o!"flags" <|> return (Flags []))
<*> o!"params"
<*> o!"lincats"
<*> o!"lins"
instance JSON ParamDef where
showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)]
readJSON o = ParamDef <$> o!"param" <*> o!"values"
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
instance JSON LincatDef where
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
instance JSON LinDef where
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
instance JSON LinType where
-- the basic types (Str, Float, Int) are encoded as strings:
showJSON (StrType) = showJSON "Str"
showJSON (FloatType) = showJSON "Float"
showJSON (IntType) = showJSON "Int"
-- parameters are also encoded as strings:
showJSON (ParamType pt) = showJSON pt
-- tables/tuples are encoded as JSON objects:
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
-- records are encoded as records:
showJSON (RecordType rows) = showJSON rows
readJSON o = do "Str" <- readJSON o; return StrType
<|> do "Float" <- readJSON o; return FloatType
<|> do "Int" <- readJSON o; return IntType
<|> do ptype <- readJSON o; return (ParamType ptype)
<|> TableType <$> o!".tblarg" <*> o!".tblval"
<|> TupleType <$> o!".tuple"
<|> RecordType <$> readJSON o
instance JSON LinValue where
showJSON (LiteralValue l ) = showJSON l
-- most values are encoded as JSON objects:
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
-- records are encoded directly as JSON records:
showJSON (RecordValue rows) = showJSON rows
-- concatenation is encoded as a JSON array:
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
where flatten (ConcatValue v v') = flatten v . flatten v'
flatten v = (v :)
readJSON o = LiteralValue <$> readJSON o
<|> ParamConstant <$> o!".param"
<|> PredefValue <$> o!".predef"
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
<|> TupleValue <$> o!".tuple"
<|> VarValue <$> o!".var"
<|> ErrorValue <$> o!".error"
<|> Projection <$> o!".project" <*> o!".label"
<|> Selection <$> o!".select" <*> o!".key"
<|> VariantValue <$> o!".variants"
<|> PreValue <$> o!".pre" <*> o!".default"
<|> RecordValue <$> readJSON o
<|> do vs <- readJSON o :: Result [LinValue]
return (foldr1 ConcatValue vs)
instance JSON LinLiteral 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
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
instance JSON LinPattern where
-- wildcards and patterns without arguments are encoded as strings:
showJSON (WildPattern) = showJSON "_"
showJSON (ParamPattern (Param p [])) = showJSON p
-- complex patterns are encoded as JSON objects:
showJSON (ParamPattern pv) = showJSON pv
-- and records as records:
showJSON (RecordPattern r) = showJSON r
readJSON o = do "_" <- readJSON o; return WildPattern
<|> do p <- readJSON o; return (ParamPattern (Param p []))
<|> ParamPattern <$> readJSON o
<|> RecordPattern <$> readJSON o
instance JSON arg => JSON (Param arg) where
-- parameters without arguments are encoded as strings:
showJSON (Param p []) = showJSON p
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
readJSON o = Param <$> readJSON o <*> return []
<|> Param <$> o!".paramid" <*> o!".args"
instance JSON a => JSON (RecordRow a) where
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows)
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (RecordRow (LabelId lbl) value)
instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
-- *** Identifiers in Concrete Syntax
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where
-- the anonymous variable is the underscore:
showJSON Anonymous = showJSON "_"
showJSON (VarId x) = showJSON x
readJSON o = do "_" <- readJSON o; return Anonymous
<|> VarId <$> readJSON o
instance JSON QualId where
showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid
return $ if null mod then Unqual id else Qual (ModId mod) id
instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects):
showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (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
(!) :: JSON a => JSValue -> String -> Result a
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
readJSON
(lookup key (assocsJSObject obj))
assocsJSObject :: JSValue -> [(String, JSValue)]
assocsJSObject (JSObject o) = fromJSObject o
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
readBasicJSON str int flt o
= str <$> readJSON o
<|> int_or_flt <$> readJSON o
where int_or_flt f | f == fromIntegral n = int n
| otherwise = flt f
where n = round f

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

@@ -208,7 +208,7 @@ ppTerm q d (S x y) = case x of
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
ppTerm q d (FV es) = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))

6
src/compiler/GF/Haskell.hs
View File

@@ -40,6 +40,9 @@ tvar = TId
tcon0 = TId
tcon c = foldl TAp (TId c)
lets [] e = e
lets ds e = Lets ds e
let1 x xe e = Lets [(x,xe)] e
single x = List [x]
@@ -113,7 +116,8 @@ instance Pretty Exp where
Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2)
Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs],
"in" <+>e]
LambdaCase alts -> hang "\\case" 4 (vcat [p<+>"->"<+>e|(p,e)<-alts])
LambdaCase alts ->
hang "\\case" 2 (vcat [hang (p<+>"->") 2 e|(p,e)<-alts])
_ -> ppB e
ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as))

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

@@ -83,7 +83,10 @@ data Phase = Preproc | Convert | Compile | Link
deriving (Show,Eq,Ord)
data OutputFormat = FmtPGFPretty
| FmtCanonicalGF
| FmtCanonicalJson
| FmtJavaScript
| FmtJSON
| FmtPython
| FmtHaskell
| FmtJava
@@ -318,7 +321,8 @@ optDescr =
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
"Multiple concrete: pgf (default), js, pgf_pretty, prolog, python, ...", -- gar,
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs,
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
@@ -366,8 +370,6 @@ optDescr =
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
Option [] ["split-pgf"] (NoArg (splitPGF True))
"Split the PGF into one file per language. This allows the runtime to load only individual languages",
Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing",
Option [] ["case_sensitive"] (onOff (\v -> set $ \o -> o{optCaseSensitive=v}) True) "Set the parser in case-sensitive/insensitive mode [sensitive by default]",
@@ -441,8 +443,6 @@ optDescr =
optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
splitPGF x = set $ \o -> o { optSplitPGF = x }
toggleOptimize x b = set $ setOptimization' x b
cfgTransform x = let (x', b) = case x of
'n':'o':'-':rest -> (rest, False)
_ -> (x, True)
@@ -465,7 +465,10 @@ outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)]
outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
(("js", FmtJavaScript),"JavaScript (whole grammar)"),
(("json", FmtJSON),"JSON (whole grammar)"),
(("python", FmtPython),"Python (whole grammar)"),
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("java", FmtJava),"Java (abstract syntax)"),

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

@@ -20,7 +20,7 @@ import GF.System.Console (setConsoleEncoding)
-- Run @gf --help@ for usage info.
main :: IO ()
main = do
setConsoleEncoding
--setConsoleEncoding
uncurry mainOpts =<< getOptions
-- | Get and parse GF command line arguments. Fix relative paths.

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

@@ -6,8 +6,8 @@
----------------------------------------------------------------------
module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
import PGF
import PGF.Internal
import PGF2
import PGF2.Internal
import GF.Grammar.CFG hiding (Symbol)
import Data.Map (Map)
@@ -16,28 +16,25 @@ import qualified Data.IntMap as IntMap
import Data.Set (Set)
import qualified Data.Set as Set
bnfPrinter :: PGF -> CId -> String
bnfPrinter :: PGF -> Concr -> String
bnfPrinter = toBNF id
toBNF :: (CFG -> CFG) -> PGF -> CId -> String
toBNF :: (CFG -> CFG) -> PGF -> Concr -> String
toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name
-> CFG
pgfToCFG pgf lang = mkCFG (showCId start_cat) extCats (startRules ++ concatMap ruleToCFRule rules)
pgfToCFG :: PGF -> Concr -> CFG
pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
where
(_,start_cat,_) = unType (startCat pgf)
cnc = lookConcr pgf lang
rules :: [(FId,Production)]
rules = [(fcat,prod) | fcat <- [0..concrTotalCats cnc],
prod <- concrProductions cnc fcat]
fcatCats :: Map FId Cat
fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
fcatCats = Map.fromList [(fc, c ++ "_" ++ show i)
| (c,s,e,lbls) <- concrCategories cnc,
(fc,i) <- zip [s..e] [1..]]
@@ -64,7 +61,7 @@ pgfToCFG pgf lang = mkCFG (showCId start_cat) extCats (startRules ++ concatMap r
extCats = Set.fromList $ map ruleLhs startRules
startRules :: [CFRule]
startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
startRules = [Rule c [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,s,e,lbls) <- concrCategories cnc,
fc <- [s..e], not (isPredefFId fc),
r <- [0..catLinArity fc-1]]
@@ -113,7 +110,7 @@ pgfToCFG pgf lang = mkCFG (showCId start_cat) extCats (startRules ++ concatMap r
where Just (hypos,_,_) = fmap unType (functionType pgf f)
argTypes = [cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]
profileToTerm :: CId -> Profile -> CFTerm
profileToTerm :: Fun -> Profile -> CFTerm
profileToTerm t [] = CFMeta t
profileToTerm _ xs = CFRes (last xs) -- FIXME: unify
ruleToCFRule (c,PCoerce c') =

4
src/compiler/GF/System/Directory.hs
View File

@@ -8,13 +8,13 @@ import System.Directory as D
doesDirectoryExist,doesFileExist,getModificationTime,
getCurrentDirectory,getDirectoryContents,getPermissions,
removeFile,renameFile)
import Data.Time.Compat
--import Data.Time.Compat
canonicalizePath path = liftIO $ D.canonicalizePath path
createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b
doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
doesFileExist path = liftIO $ D.doesFileExist path
getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path)
getModificationTime path = liftIO $ {-fmap toUTCTime-} (D.getModificationTime path)
getDirectoryContents path = liftIO $ D.getDirectoryContents path
getCurrentDirectory :: MonadIO io => io FilePath

1
src/compiler/GF/Text/Pretty.hs
View File

@@ -20,6 +20,7 @@ instance Pretty a => Pretty [a] where
ppList = fsep . map pp -- hmm
render x = PP.render (pp x)
render80 x = renderStyle style{lineLength=80,ribbonsPerLine=1} x
renderStyle s x = PP.renderStyle s (pp x)
infixl 5 $$,$+$

553
src/example-based/ExampleDemo.hs
View File

@@ -1,553 +0,0 @@
module ExampleDemo (Environ,initial,getNext, provideExample, testThis,mkFuncWithArg,searchGoodTree,isMeta)
where
import PGF
--import System.IO
import Data.List
--import Control.Monad
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Data.Maybe
--import System.Environment (getArgs)
import System.Random (RandomGen) --newStdGen
type MyType = CId -- name of the categories from the program
type ConcType = CId -- categories from the resource grammar, that we parse on
type MyFunc = CId -- functions that we need to implement
--type FuncWithArg = ((MyFunc, MyType), Expr) -- function with arguments
type InterInstr = [String] -- lincats that were generated but not written to the file
data FuncWithArg = FuncWithArg
{getName :: MyFunc, -- name of the function to generate
getType :: MyType, -- return type of the function
getTypeArgs :: [MyType] -- types of arguments
}
deriving (Show,Eq,Ord)
-- we assume that it's for English for the moment
type TypeMap = Map.Map MyType ConcType -- mapping found from a file
type ConcMap = Map.Map MyFunc Expr -- concrete expression after parsing
data Environ = Env {getTypeMap :: TypeMap, -- mapping between a category in the grammar and a concrete type from RGL
getConcMap :: ConcMap, -- concrete expression after parsing
getSigs :: Map.Map MyType [FuncWithArg], -- functions for which we have the concrete syntax already with args
getAll :: [FuncWithArg] -- all the functions with arguments
}
getNext :: Environ -> Environ -> ([MyFunc],[MyFunc])
getNext env example_env =
let sgs = getSigs env
allfuncs = getAll env
names = Set.fromList $ map getName $ concat $ Map.elems sgs
exampleable = filter (\x -> (isJust $ getNameExpr x env)
&&
(not $ Set.member x names) -- maybe drop this if you want to also rewrite from examples...
) $ map getName allfuncs
testeable = filter (\x -> (isJust $ getNameExpr x env )
&&
(Set.member x names)
) $ map getName allfuncs
in (exampleable,testeable)
provideExample :: RandomGen gen => gen -> Environ -> MyFunc -> PGF -> PGF -> Language -> Maybe (Expr,String)
provideExample gen env myfunc parsePGF pgfFile lang =
fmap giveExample $ getNameExpr myfunc env
where
giveExample e_ =
let newexpr = head $ generateRandomFromDepth gen pgfFile e_ (Just 5) -- change here with the new random generator
ty = getType $ head $ filter (\x -> getName x == myfunc) $ getAll env
embeddedExpr = maybe "" (\x -> ", as in: " ++ q (linearize pgfFile lang x)) (embedInStart (getAll env) (Map.fromList [(ty,e_)]))
lexpr = linearize pgfFile lang newexpr
q s = sq++s++sq
sq = "\""
in (newexpr,q lexpr ++ embeddedExpr)
-- question, you need the IO monad for the random generator, how to do otherwise ??
-- question can you make the expression bold/italic - somehow distinguishable from the rest ?
testThis :: Environ -> MyFunc -> PGF -> Language -> Maybe String
testThis env myfunc parsePGF lang =
fmap (linearize parsePGF lang . mapToResource env . llin env) $
getNameExpr myfunc env
-- we assume that even the functions linearized by the user will still be in getSigs along with their linearization
-- fill in the blancs of an expression that we want to linearize for testing purposes
---------------------------------------------------------------------------
llin :: Environ -> Expr -> Expr
llin env expr =
let
(id,args) = fromJust $ unApp expr
--cexpr = fromJust $ Map.lookup id (getConcMap env)
in
if any isMeta args
then let
sigs = concat $ Map.elems $ getSigs env
tys = findExprWhich sigs id
in replaceConcArg 1 tys expr env
else mkApp id $ map (llin env) args
-- argument of the meta variable to replace, list of arguments left, expression to replace, environment, current replace expression
replaceConcArg :: Int -> [MyType] -> Expr -> Environ -> Expr
replaceConcArg i [] expr env = expr
replaceConcArg i (t:ts) expr env = -- TO DO : insert randomness here !!
let ss = fromJust $ Map.lookup t $ getSigs env
args = filter (null . getTypeArgs) ss
finArg = if null args then let l = last ss in llin env (mkApp (getName l) [mkMeta j | j <- [1..(length $ getTypeArgs l)]])
else mkApp (getName $ last args) []
in
let newe = replaceOne i finArg expr
in replaceConcArg (i+1) ts newe env
-- replace a certain metavariable with a certain expression in another expression - return updated expression
replaceOne :: Int -> Expr -> Expr -> Expr
replaceOne i erep expr =
if isMeta expr && ((fromJust $ unMeta expr) == i)
then erep
else if isMeta expr then expr
else let (id,args) = fromJust $ unApp expr
in
mkApp id $ map (replaceOne i erep) args
findExprWhich :: [FuncWithArg] -> MyFunc -> [MyType]
findExprWhich lst f = getTypeArgs $ head $ filter (\x -> getName x == f) lst
mapToResource :: Environ -> Expr -> Expr
mapToResource env expr =
let (id,args) = maybe (error $ "tried to unwrap " ++ showExpr [] expr) (\x -> x) (unApp expr)
cmap = getConcMap env
cexp = maybe (error $ "didn't find " ++ showCId id ++ " in "++ show cmap) (\x -> x) (Map.lookup id cmap)
in
if null args then cexp
else let newargs = map (mapToResource env) args
in replaceAllArgs cexp 1 newargs
where
replaceAllArgs expr i [] = expr
replaceAllArgs expr i (x:xs) = replaceAllArgs (replaceOne i x expr) (i+1) xs
-----------------------------------------------
-- embed expression in another one from the start category
embedInStart :: [FuncWithArg] -> Map.Map MyType Expr -> Maybe Expr
embedInStart fss cs =
let currset = Map.toList cs
nextset = Map.fromList $ concat [ if elem myt (getTypeArgs farg)
then connectWithArg (myt,exp) farg else []
| (myt,exp) <- currset, farg <- fss]
nextmap = Map.union cs nextset
maybeExpr = Map.lookup startCateg nextset
in if isNothing maybeExpr then
if Map.size nextmap == Map.size cs then Nothing --error $ "could't build " ++ show startCateg ++ "with " ++ show fss
else embedInStart fss nextmap
else return $ fromJust maybeExpr
where
connectWithArg (myt,exp) farg =
let ind = head $ elemIndices myt (getTypeArgs farg)
in [(getType farg, mkApp (getName farg) $ [mkMeta i | i <- [1..ind]] ++ [exp] ++ [mkMeta i | i <- [(ind + 1)..((length $ getTypeArgs farg) - 1)]])]
-----------------------------------------------
{-
updateConcMap :: Environ -> MyFunc -> Expr -> Environ
updateConcMap env myf expr =
Env (getTypeMap env) (Map.insert myf expr (getConcMap env)) (getSigs env) (getAll env)
updateInterInstr :: Environ -> MyType -> FuncWithArg -> Environ
updateInterInstr env myt myf =
let ii = getSigs env
newInterInstr =
maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
in Env (getTypeMap env) (getConcMap env) newInterInstr (getAll env)
putSignatures :: Environ -> [FuncWithArg] -> Environ
putSignatures env fss =
Env (getTypeMap env) (getConcMap env) (mkSigs fss) (getAll env)
updateEnv :: Environ -> FuncWithArg -> MyType -> Expr -> Environ
updateEnv env myf myt expr =
let ii = getSigs env
nn = getName myf
newInterInstr =
maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
in Env (getTypeMap env) (Map.insert nn expr (getConcMap env)) newInterInstr (getAll env)
-}
mkSigs :: [FuncWithArg] -> Map.Map MyType [FuncWithArg]
mkSigs fss = Map.fromListWith (++) $ zip (map getType fss) (map (\x -> [x]) fss)
{------------------------------------
lang :: String
lang = "Eng"
parseLang :: Language
parseLang = fromJust $ readLanguage "ParseEng"
parsePGFfile :: String
parsePGFfile = "ParseEngAbs.pgf"
------------------------------------}
searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr,Expr))
searchGoodTree env expr [] = return Nothing
searchGoodTree env expr (e:es) =
do val <- debugReplaceArgs expr e env
maybe (searchGoodTree env expr es) (\x -> return $ Just (x,e)) val
getNameExpr :: MyFunc -> Environ -> Maybe Expr
getNameExpr myfunc env =
let allfunc = filter (\x -> getName x == myfunc) $ getAll env
in
if null allfunc then Nothing
else getExpr (head allfunc) env
-- find an expression to generate where we have all the other elements available
getExpr :: FuncWithArg -> Environ -> Maybe Expr
getExpr farg env =
let tys = getTypeArgs farg
ctx = getSigs env
lst = getConcTypes ctx tys 1
in if (all isJust lst) then Just $ mkApp (getName farg) (map fromJust lst)
else Nothing
where getConcTypes context [] i = []
getConcTypes context (ty:types) i =
let pos = Map.lookup ty context
in
if isNothing pos || (null $ fromJust pos) then [Nothing]
else
let mm = last $ fromJust pos
mmargs = getTypeArgs mm
newi = i + length mmargs - 1
lst = getConcTypes (Map.insert ty (init $ (fromJust pos)) context) types (newi+1)
in
if (all isJust lst) then -- i..newi
(Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst
else [Nothing]
-- only covers simple expressions with meta variables, not the rest...
isGeneralizationOf :: Expr -> Expr -> Bool
isGeneralizationOf genExpr testExpr =
if isMeta genExpr then True
else if isMeta testExpr then False
else let genUnwrap = unApp genExpr
testUnwrap = unApp testExpr
in if isNothing genUnwrap || isNothing testUnwrap then False -- see if you can generalize here
else let (gencid, genargs) = fromJust genUnwrap
(testcid, testargs) = fromJust testUnwrap
in
(gencid == testcid) && (length genargs == length testargs)
&& (and [isGeneralizationOf g t | (g,t) <- (zip genargs testargs)])
{-do lst <- getConcTypes context types (i+1)
return $ mkMeta i : lst -}
debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr)
debugReplaceArgs aexpr cexpr env =
if isNothing $ unApp aexpr then return Nothing
else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then return Nothing
else
let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
in startReplace 1 cexpr concExprs
where
startReplace i cex [] = return $ Just cex
startReplace i cex (a:as) = do val <- debugReplaceConc cex i a
maybe ( --do putStrLn $ "didn't find "++ showExpr [] a ++ " in " ++showExpr [] cexpr
return Nothing)
(\x -> --do putStrLn $ "found it, the current expression is "++ showExpr [] x
startReplace (i+1) x as)
val
debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr)
debugReplaceConc expr i e =
let (newe,isThere) = searchArg expr
in if isThere then return $ Just newe else return $ Nothing
where
searchArg e_ =
if isGeneralizationOf e e_ then (mkMeta i, True)
else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_
{-
-- replaceArgs : Original expression to parse (from abstract syntax) -> Concrete expression (parsed)
replaceArgs :: Expr -> Expr -> Environ -> Maybe Expr
replaceArgs aexpr cexpr env =
if isNothing $ unApp aexpr then error $ "could't unwrap this "++ show aexpr
else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then error $ "couldn't unwrap more this : "++ show aexpr
else
let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
in startReplace 1 cexpr concExprs
where
startReplace i cex [] = return cex
startReplace i cex (a:as) = maybe Nothing (\x -> startReplace (i+1) x as) $ replaceConc cex i a
replaceConc :: Expr -> Int -> Expr -> Maybe Expr
replaceConc expr i e =
let (newe,isThere) = searchArg expr
in if isThere then return newe else Nothing
where
searchArg e_ =
if isGeneralizationOf e e_ then (mkMeta i, True)
else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_
writeResults :: Environ -> String -> IO ()
writeResults env fileName =
let cmap = getConcMap env
lincats = unlines $ map (\(x,y) -> "lincat " ++ showCId x ++ " = " ++ showCId y ++ " ; " ) $ Map.toList $ getTypeMap env
sigs = unlines $ map
(\x -> let n = getName x
no = length $ getTypeArgs x
oargs = unwords $ ("lin " ++ showCId n) : ["o"++show i | i <- [1..no]]
in (oargs ++ " = " ++ (simpleReplace $ showExpr [] $ fromJust $ Map.lookup n cmap) ++ " ; ")) $ concat $ Map.elems $ getSigs env
in
writeFile fileName ("\n" ++ lincats ++ "\n\n" ++ sigs)
simpleReplace :: String -> String
simpleReplace [] = []
simpleReplace ('?':xs) = 'o' : simpleReplace xs
simpleReplace (x:xs) = x : simpleReplace xs
-}
isMeta :: Expr -> Bool
isMeta = isJust.unMeta
-- works with utf-8 characters also, as it seems
mkFuncWithArg :: ((CId,CId),[CId]) -> FuncWithArg
mkFuncWithArg ((c1,c2),cids) = FuncWithArg c1 c2 cids
---------------------------------------------------------------------------------
initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ
initial tm cm fss allfs = Env tm cm (mkSigs fss) allfs
{-
testInit :: [FuncWithArg] -> Environ
testInit allfs = initial lTypes Map.empty [] allfs
lTypes = Map.fromList [(mkCId "Comment", mkCId "S"),(mkCId "Item", mkCId "NP"), (mkCId "Kind", mkCId "CN"), (mkCId "Quality", mkCId "AP")]
-}
startCateg = mkCId "Comment"
-- question about either to give the startcat or not ...
----------------------------------------------------------------------------------------------------------
{-
main =
do args <- getArgs
case args of
[pgfFile] ->
do pgf <- readPGF pgfFile
parsePGF <- readPGF parsePGFfile
fsWithArg <- forExample pgf
let funcsWithArg = map (map mkFuncWithArg) fsWithArg
let morpho = buildMorpho parsePGF parseLang
let fss = concat funcsWithArg
let fileName = takeWhile (/='.') pgfFile ++ lang ++ ".gf"
env <- start parsePGF pgf morpho (testInit fss) fss
putStrLn $ "Should I write the results to a file ? yes/no"
ans <-getLine
if ans == "yes" then do writeResults env fileName
putStrLn $ "Wrote file " ++ fileName
else return ()
_ -> fail "usage : Testing <path-to-pgf> "
start :: PGF -> PGF -> Morpho -> Environ -> [FuncWithArg] -> IO Environ
start parsePGF pgfFile morpho env lst =
do putStrLn "Do you want examples from another language ? (no/concrete syntax name otherwise)"
ans1 <- getLine
putStrLn "Do you want testing mode ? (yes/no)"
ans2 <- getLine
case (ans1,ans2) of
("no","no") -> do putStrLn "no extra language, just the abstract syntax tree"
interact env lst False Nothing
(_,"no") -> interact env lst False (readLanguage ans1)
("no","yes") -> do putStrLn "no extra language, just the abstract syntax tree"
interact env lst True Nothing
(_,"yes") -> interact env lst True (readLanguage ans1)
("no",_) -> do putStrLn "no extra language, just the abstract syntax tree"
putStrLn $ "I assume you don't want the testing mode ... "
interact env lst False Nothing
(_,_) -> do putStrLn $ "I assume you don't want the testing mode ... "
interact env lst False (readLanguage ans1)
where
interact environ [] func _ = return environ
interact environ (farg:fargs) boo otherLang =
do
maybeEnv <- basicInter farg otherLang environ boo
if isNothing maybeEnv then return environ
else interact (fromJust maybeEnv) fargs boo otherLang
basicInter farg js environ False =
let e_ = getExpr farg environ in
if isNothing e_ then return $ Just environ
else parseAndBuild farg js environ (getType farg) e_ Nothing
basicInter farg js environ True =
let (e_,e_test) = get2Expr farg environ in
if isNothing e_ then return $ Just environ
else if isNothing e_test then do putStrLn $ "not enough arguments "++ (showCId $ getName farg)
parseAndBuild farg js environ (getType farg) e_ Nothing
else parseAndBuild farg js environ (getType farg) e_ e_test
-- . head . generateRandomFrom gen2 pgfFile
parseAndBuild farg js environ ty e_ e_test =
do let expr = fromJust e_
gen1 <- newStdGen
gen2 <- newStdGen
let newexpr = head $ generateRandomFrom gen1 pgfFile expr
let embeddedExpr = maybe "***" (showExpr [] ) (embedInStart (getAll environ) (Map.fromList [(ty,expr)]))
let lexpr = if isNothing js then "" else "\n-- " ++ linearize pgfFile (fromJust js) newexpr ++ " --"
putStrLn $ "Give an example for " ++ (showExpr [] expr)
++ lexpr ++ "and now"
++ "\n\nas in " ++ embeddedExpr ++ "\n\n"
--
ex <- getLine
if (ex == ":q") then return Nothing
else
let ctype = fromJust $ Map.lookup (getType farg) (getTypeMap environ) in
do env' <- decypher farg ex expr environ (fromJust $ readType $ showCId ctype) e_test
return (Just env')
decypher farg ex expr environ ty e_test =
--do putStrLn $ "We need to parse " ++ ex ++ " as " ++ show ctype
let pTrees = parse parsePGF (fromJust $ readLanguage "ParseEng") ty ex in
pickTree farg expr environ ex e_test pTrees
-- putStrLn $ "And now for testing, \n is this also correct yes/no \n ## " ++ (linearize parsePGF parseLang $ mapToResource newenv $ llin newenv e_test) ++ " ##"
-- select the right tree among the options given by the parser
pickTree farg expr environ ex e_test [] =
let miswords = morphoMissing morpho (words ex)
in
if null miswords then do putStrLn $ "all words known, but some syntactic construction is not covered by the grammar..."
return environ
else do putStrLn $ "the following words are unknown, please add them to the lexicon: " ++ show miswords
return environ
pickTree farg expr environ ex e_test [tree] =
do val <- searchGoodTree environ expr [tree] -- maybe order here after the probabilities for better precision
maybe (do putStrLn $ "none of the trees is consistent with the rest of the grammar, please check arguments "
return environ)
(\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
do putStrLn $ "the result is "++showExpr [] x
newtestenv <- testTest newenv e_test -- question ? should it belong there - there is just one possibility of a tree...
return newenv) val
pickTree farg expr environ ex e_test parseTrees =
do putStrLn $ "There is more than one possibility, do you want to choose the right tree yourself ? yes/no "
putStr " >"
ans <- getLine
if ans == "yes" then do pTree <- chooseRightTree parseTrees
processTree farg environ expr pTree e_test
else processTree farg environ expr parseTrees e_test
-- introduce testing function, if it doesn't work, then reparse, take that tree
testTree envv e_test = return envv -- TO DO - add testing here
testTest envv Nothing = return envv
testTest envv (Just exxpr) = testTree envv exxpr
-- allows the user to pick his own tree
chooseRightTree trees = return trees -- TO DO - add something clever here
-- selects the tree from where one can abstract over the original arguments
processTree farg environ expr lsTrees e_test =
let trmes = if length lsTrees == 1 then "the tree is not consistent " else "none of the trees is consistent " in
do val <- searchGoodTree environ expr lsTrees
maybe (do putStrLn $ trmes ++ "with the rest of the grammar, please check arguments! "
return environ)
(\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
do putStrLn $ "the result is "++showExpr [] x
newtestenv <- testTest newenv e_test
return newenv) val
-------------------------------
get2Expr :: FuncWithArg -> Environ -> (Maybe Expr, Maybe Expr)
get2Expr farg env =
let tys = getTypeArgs farg
ctx = getSigs env
(lst1,lst2) = getConcTypes2 ctx tys 1
arg1 = if (all isJust lst1) then Just $ mkApp (getName farg) (map fromJust lst1) else Nothing
arg2 = if (all isJust lst2) then Just $ mkApp (getName farg) (map fromJust lst2) else Nothing
in if arg1 == arg2 then (arg1, Nothing)
else (arg1,arg2)
where
getConcTypes2 context [] i = ([],[])
getConcTypes2 context (ty:types) i =
let pos = Map.lookup ty context
in
if isNothing pos || (null $ fromJust pos) then ([Nothing],[Nothing])
else
let (mm,tt) = (last $ fromJust pos, head $ fromJust pos)
mmargs = getTypeArgs mm
newi = i + length mmargs - 1
(lst1,lst2) = getConcTypes2 (Map.insert ty (init (fromJust pos)) context) types (newi+1)
ttargs = getTypeArgs tt
newtti = i + length ttargs - 1
fstArg = if (all isJust lst1) then -- i..newi
(Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst1
else [Nothing]
sndArg = if (all isJust lst2) then
(Just $ mkApp (getName tt) [mkMeta j | j <- [1..(length ttargs)]]) : lst2
else [Nothing]
in
(fstArg,sndArg)
-}

128
src/example-based/ExampleService.hs
View File

@@ -1,128 +0,0 @@
module ExampleService(cgiMain,cgiMain',newPGFCache) where
import System.Random(newStdGen)
import System.FilePath((</>),makeRelative)
import Data.Map(fromList)
import Data.Char(isDigit)
import Data.Maybe(fromJust)
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import PGF
import GF.Compile.ToAPI
import Network.CGI
import Text.JSON
import CGIUtils
import Cache
import qualified ExampleDemo as E
newPGFCache = newCache readPGF
cgiMain :: Cache PGF -> CGI CGIResult
cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."
cgiMain' root cwd cache =
do command <- getInp "command"
environ <- parseEnviron =<< getInp "state"
case command of
"possibilities" -> doPossibilities environ
"provide_example" -> doProvideExample root cwd cache environ
"abstract_example" -> doAbstractExample cwd cache environ
"test_function" -> doTestFunction cwd cache environ
_ -> throwCGIError 400 ("Unknown command: "++command) []
doPossibilities environ =
do example_environ <- parseEnviron =<< getInp "example_state"
outputJSONP (E.getNext environ example_environ)
doProvideExample root cwd cache environ =
do Just lang <- readInput "lang"
fun <- getCId "fun"
parsePGF <- readParsePGF cwd cache
let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path)
pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar"
gen <- liftIO newStdGen
let Just (e,s) = E.provideExample gen environ fun parsePGF pgf lang
res = (showExpr [] e,s)
liftIO $ logError $ "proveExample ... = "++show res
outputJSONP res
doAbstractExample cwd cache environ =
do example <- getInp "input"
Just params <- readInput "params"
absstr <- getInp "abstract"
Just abs <- return $ readExpr absstr
liftIO $ logError $ "abstract = "++showExpr [] abs
Just cat <- readInput "cat"
let t = mkType [] cat []
parsePGF <- readParsePGF cwd cache
let lang:_ = languages parsePGF
ae <- liftIO $ abstractExample parsePGF environ lang t abs example
outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae)
abstractExample parsePGF env lang cat abs example =
E.searchGoodTree env abs (parse parsePGF lang cat example)
doTestFunction cwd cache environ =
do fun <- getCId "fun"
parsePGF <- readParsePGF cwd cache
let lang:_ = languages parsePGF
Just txt <- return (E.testThis environ fun parsePGF lang)
outputJSONP txt
getCId :: String -> CGI CId
getCId name = maybe err return =<< fmap readCId (getInp name)
where err = throwCGIError 400 ("Bad "++name) []
{-
getLimit :: CGI Int
getLimit = maybe err return =<< readInput "limit"
where err = throwCGIError 400 "Missing/bad limit" []
-}
readParsePGF cwd cache =
do parsepgf <- getInp "parser"
liftIO $ readCache cache (cwd</>parsepgf)
parseEnviron s = do state <- liftIO $ readIO s
return $ environ state
getInp name = maybe err (return . UTF8.decodeString) =<< getInput name
where err = throwCGIError 400 ("Missing parameter: "++name) []
instance JSON CId where
showJSON = showJSON . show
readJSON = (readResult =<<) . readJSON
instance JSON Expr where
showJSON = showJSON . showExpr []
readJSON = (m2r . readExpr =<<) . readJSON
m2r = maybe (Error "read failed") Ok
readResult s = case reads s of
(x,r):_ | lex r==[("","")] -> Ok x
_ -> Error "read failed"
--------------------------------------------------------------------------------
-- cat lincat fun lin fun cat cat
environ :: ([(CId, CId)],[(CId, Expr)],[((CId, CId), [CId])]) -> E.Environ
environ (lincats,lins0,funs) =
E.initial (fromList lincats) concmap fs allfs
where
concmap = fromList lins
allfs = map E.mkFuncWithArg funs
fs = [E.mkFuncWithArg f | f@((fn,_),_)<-funs, fn `elem` cns]
cns = map fst lins
lins = filter (not . E.isMeta .snd) lins0
instExpMeta :: [CId] -> Expr -> Expr
instExpMeta ps = fromJust . readExpr . instMeta ps . showExpr []
instMeta :: [CId] -> String -> String
instMeta ps s =
case break (=='?') s of
(s1,'?':s2) ->
case span isDigit s2 of
(s21@(_:_),s22) -> s1++show (ps!!(read s21-1))++instMeta ps s22
("",s22) -> s1++'?':instMeta ps s22
(_,_) -> s

15
src/example-based/exb-fcgi.hs
View File

@@ -1,15 +0,0 @@
{-# LANGUAGE CPP #-}
import Control.Concurrent(forkIO)
import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
import ExampleService(cgiMain,newPGFCache)
main = do --stderrToFile logFile
fcgiMain =<< newPGFCache
fcgiMain cache =
#ifndef mingw32_HOST_OS
runFastCGIConcurrent' forkIO 100 (cgiMain cache)
#else
runFastCGI (cgiMain cache)
#endif

25
src/example-based/gf-exb.cabal
View File

@@ -1,25 +0,0 @@
Name: gf-exb
Version: 1.0
Cabal-version: >= 1.8
Build-type: Simple
License: GPL
Synopsis: Example-based grammar writing for the Grammatical Framework
executable exb.fcgi
main-is: exb-fcgi.hs
Hs-source-dirs: . ../server ../compiler ../runtime/haskell
other-modules: ExampleService ExampleDemo
FastCGIUtils Cache GF.Compile.ToAPI
-- and a lot more...
ghc-options: -threaded
if impl(ghc>=7.0)
ghc-options: -rtsopts
build-depends: base >=4.2 && <5, json, cgi, fastcgi, random,
containers, old-time, directory, bytestring, utf8-string,
pretty, array, mtl, fst, filepath
if os(windows)
ghc-options: -optl-mwindows
else
build-depends: unix

20
src/example-based/todo.txt
View File

@@ -1,20 +0,0 @@
Editor improvements for example-based grammar writing:
+ Remove the same language from the example language menu
+ Send the other language environment to getNext
- Compile a new .pgf automatically when needed
- Update buttons automatically when functions are added or removed
- Switch over to using AbsParadigmsEng.pgf instead of the old exprToAPI function
Editor support for guided construction of linearization functions
- enter api expressions by parsing them with AbsParadigmsEng.pgf in minibar
- replace simpleParseInput with one that accepts quoted string literals
- use lexcode/unlexcode in minibar
- better support for literals in minibar (completion info from the PGF
library should indicate if literals are acceptable)
Server support for example-based grammar writing:
- Change getNext to use info from the example language
- Random generator restricted to defined functions
- More testing

489
src/pgf-binary/PGF/Data/Binary.hs
View File

@@ -1,489 +0,0 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
-- | This is a layer on top of "Data.Binary" with its own 'Binary' class
-- and customised instances for 'Word', 'Int' and 'Double'.
-- The 'Int' and 'Word' instance use a variable-length encoding to save space
-- for small numbers. The 'Double' instance uses the standard IEEE754 encoding.
module PGF.Data.Binary (
-- * The Binary class
Binary(..)
-- * The Get and Put monads
, Get , Put, runPut
-- * Useful helpers for writing instances
, putWord8 , getWord8 , putWord16be , getWord16be
-- * Binary serialisation
, encode , decode
-- * IO functions for serialisation
, encodeFile , decodeFile
, encodeFile_ , decodeFile_
-- * Useful
, Word8, Word16
) where
import Data.Word
import qualified Data.Binary as Bin
import Data.Binary.Put
import Data.Binary.Get
import Data.Binary.IEEE754 ( putFloat64be, getFloat64be)
import Control.Monad
import Control.Exception
import Foreign
import System.IO
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
--import Data.Char (chr,ord)
--import Data.List (unfoldr)
-- And needed for the instances:
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
--import qualified Data.Ratio as R
--import qualified Data.Tree as T
import Data.Array.Unboxed
------------------------------------------------------------------------
-- | The @Binary@ class provides 'put' and 'get', methods to encode and
-- decode a Haskell value to a lazy ByteString. It mirrors the Read and
-- Show classes for textual representation of Haskell types, and is
-- suitable for serialising Haskell values to disk, over the network.
--
-- For parsing and generating simple external binary formats (e.g. C
-- structures), Binary may be used, but in general is not suitable
-- for complex protocols. Instead use the Put and Get primitives
-- directly.
--
-- Instances of Binary should satisfy the following property:
--
-- > decode . encode == id
--
-- That is, the 'get' and 'put' methods should be the inverse of each
-- other. A range of instances are provided for basic Haskell types.
--
class Binary t where
-- | Encode a value in the Put monad.
put :: t -> Put
-- | Decode a value in the Get monad
get :: Get t
------------------------------------------------------------------------
-- Wrappers to run the underlying monad
-- | Encode a value using binary serialisation to a lazy ByteString.
--
encode :: Binary a => a -> ByteString
encode = runPut . put
{-# INLINE encode #-}
-- | Decode a value from a lazy ByteString, reconstructing the original structure.
--
decode :: Binary a => ByteString -> a
decode = runGet get
------------------------------------------------------------------------
-- Convenience IO operations
-- | Lazily serialise a value to a file
--
-- This is just a convenience function, it's defined simply as:
--
-- > encodeFile f = B.writeFile f . encode
--
-- So for example if you wanted to compress as well, you could use:
--
-- > B.writeFile f . compress . encode
--
encodeFile :: Binary a => FilePath -> a -> IO ()
encodeFile f v = L.writeFile f (encode v)
encodeFile_ :: FilePath -> Put -> IO ()
encodeFile_ f m = L.writeFile f (runPut m)
-- | Lazily reconstruct a value previously written to a file.
--
-- This is just a convenience function, it's defined simply as:
--
-- > decodeFile f = return . decode =<< B.readFile f
--
-- So for example if you wanted to decompress as well, you could use:
--
-- > return . decode . decompress =<< B.readFile f
--
decodeFile :: Binary a => FilePath -> IO a
decodeFile f = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
s <- L.hGetContents h
evaluate $ runGet get s
decodeFile_ :: FilePath -> Get a -> IO a
decodeFile_ f m = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
s <- L.hGetContents h
evaluate $ runGet m s
------------------------------------------------------------------------
-- For ground types, the standard instances can be reused,
-- but for container types it would imply using
-- the standard instances for all types of values in the container...
instance Binary () where put=Bin.put; get=Bin.get
instance Binary Bool where put=Bin.put; get=Bin.get
instance Binary Word8 where put=Bin.put; get=Bin.get
instance Binary Word16 where put=Bin.put; get=Bin.get
instance Binary Char where put=Bin.put; get=Bin.get
-- -- GF doesn't need these:
--instance Binary Ordering where put=Bin.put; get=Bin.get
--instance Binary Word32 where put=Bin.put; get=Bin.get
--instance Binary Word64 where put=Bin.put; get=Bin.get
--instance Binary Int8 where put=Bin.put; get=Bin.get
--instance Binary Int16 where put=Bin.put; get=Bin.get
--instance Binary Int32 where put=Bin.put; get=Bin.get
--instance Binary Int64 where put=Bin.put; get=Bin.get -- needed by instance Binary ByteString
------------------------------------------------------------------------
-- Words are written as sequence of bytes. The last bit of each
-- byte indicates whether there are more bytes to be read
instance Binary Word where
put i | i <= 0x7f = do put a
| i <= 0x3fff = do put (a .|. 0x80)
put b
| i <= 0x1fffff = do put (a .|. 0x80)
put (b .|. 0x80)
put c
| i <= 0xfffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put d
-- -- #if WORD_SIZE_IN_BITS < 64
| otherwise = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put e
{-
-- Restricted to 32 bits even on 64-bit systems, so that negative
-- Ints are written as 5 bytes instead of 10 bytes (TH 2013-02-13)
--#else
| i <= 0x7ffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put e
| i <= 0x3ffffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put f
| i <= 0x1ffffffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put (f .|. 0x80)
put g
| i <= 0xffffffffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put (f .|. 0x80)
put (g .|. 0x80)
put h
| i <= 0xffffffffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put (f .|. 0x80)
put (g .|. 0x80)
put h
| i <= 0x7fffffffffffffff = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put (f .|. 0x80)
put (g .|. 0x80)
put (h .|. 0x80)
put j
| otherwise = do put (a .|. 0x80)
put (b .|. 0x80)
put (c .|. 0x80)
put (d .|. 0x80)
put (e .|. 0x80)
put (f .|. 0x80)
put (g .|. 0x80)
put (h .|. 0x80)
put (j .|. 0x80)
put k
-- #endif
-}
where
a = fromIntegral ( i .&. 0x7f) :: Word8
b = fromIntegral (shiftR i 7 .&. 0x7f) :: Word8
c = fromIntegral (shiftR i 14 .&. 0x7f) :: Word8
d = fromIntegral (shiftR i 21 .&. 0x7f) :: Word8
e = fromIntegral (shiftR i 28 .&. 0x7f) :: Word8
{-
f = fromIntegral (shiftR i 35 .&. 0x7f) :: Word8
g = fromIntegral (shiftR i 42 .&. 0x7f) :: Word8
h = fromIntegral (shiftR i 49 .&. 0x7f) :: Word8
j = fromIntegral (shiftR i 56 .&. 0x7f) :: Word8
k = fromIntegral (shiftR i 63 .&. 0x7f) :: Word8
-}
get = do i <- getWord8
(if i <= 0x7f
then return (fromIntegral i)
else do n <- get
return $ (n `shiftL` 7) .|. (fromIntegral (i .&. 0x7f)))
-- Int has the same representation as Word
instance Binary Int where
put i = put (fromIntegral i :: Word)
get = liftM toInt32 (get :: Get Word)
where
-- restrict to 32 bits (for PGF portability, TH 2013-02-13)
toInt32 w = fromIntegral (fromIntegral w::Int32)::Int
------------------------------------------------------------------------
--
-- Portable, and pretty efficient, serialisation of Integer
--
-- Fixed-size type for a subset of Integer
--type SmallInt = Int32
-- Integers are encoded in two ways: if they fit inside a SmallInt,
-- they're written as a byte tag, and that value. If the Integer value
-- is too large to fit in a SmallInt, it is written as a byte array,
-- along with a sign and length field.
{-
instance Binary Integer where
{-# INLINE put #-}
put n | n >= lo && n <= hi = do
putWord8 0
put (fromIntegral n :: SmallInt) -- fast path
where
lo = fromIntegral (minBound :: SmallInt) :: Integer
hi = fromIntegral (maxBound :: SmallInt) :: Integer
put n = do
putWord8 1
put sign
put (unroll (abs n)) -- unroll the bytes
where
sign = fromIntegral (signum n) :: Word8
{-# INLINE get #-}
get = do
tag <- get :: Get Word8
case tag of
0 -> liftM fromIntegral (get :: Get SmallInt)
_ -> do sign <- get
bytes <- get
let v = roll bytes
return $! if sign == (1 :: Word8) then v else - v
--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: Integer -> [Word8]
unroll = unfoldr step
where
step 0 = Nothing
step i = Just (fromIntegral i, i `shiftR` 8)
roll :: [Word8] -> Integer
roll = foldr unstep 0
where
unstep b a = a `shiftL` 8 .|. fromIntegral b
instance (Binary a,Integral a) => Binary (R.Ratio a) where
put r = put (R.numerator r) >> put (R.denominator r)
get = liftM2 (R.%) get get
-}
------------------------------------------------------------------------
-- Instances for the first few tuples
instance (Binary a, Binary b) => Binary (a,b) where
put (a,b) = put a >> put b
get = liftM2 (,) get get
instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
put (a,b,c) = put a >> put b >> put c
get = liftM3 (,,) get get get
instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
put (a,b,c,d) = put a >> put b >> put c >> put d
get = liftM4 (,,,) get get get get
instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e
get = liftM5 (,,,,) get get get get get
--
-- and now just recurse:
--
instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
=> Binary (a,b,c,d,e,f) where
put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))
get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)
instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
=> Binary (a,b,c,d,e,f,g) where
put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h)
=> Binary (a,b,c,d,e,f,g,h) where
put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h, Binary i)
=> Binary (a,b,c,d,e,f,g,h,i) where
put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)
instance (Binary a, Binary b, Binary c, Binary d, Binary e,
Binary f, Binary g, Binary h, Binary i, Binary j)
=> Binary (a,b,c,d,e,f,g,h,i,j) where
put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)
------------------------------------------------------------------------
-- Container types
instance Binary a => Binary [a] where
put l = put (length l) >> mapM_ put l
get = do n <- get :: Get Int
xs <- replicateM n get
return xs
instance (Binary a) => Binary (Maybe a) where
put Nothing = putWord8 0
put (Just x) = putWord8 1 >> put x
get = do
w <- getWord8
case w of
0 -> return Nothing
_ -> liftM Just get
instance (Binary a, Binary b) => Binary (Either a b) where
put (Left a) = putWord8 0 >> put a
put (Right b) = putWord8 1 >> put b
get = do
w <- getWord8
case w of
0 -> liftM Left get
_ -> liftM Right get
------------------------------------------------------------------------
-- ByteStrings (have specially efficient instances)
instance Binary B.ByteString where
put bs = do put (B.length bs)
putByteString bs
get = get >>= getByteString
--
-- Using old versions of fps, this is a type synonym, and non portable
--
-- Requires 'flexible instances'
--
{-
instance Binary ByteString where
put bs = do put (fromIntegral (L.length bs) :: Int)
putLazyByteString bs
get = get >>= getLazyByteString
-}
------------------------------------------------------------------------
-- Maps and Sets
instance (Ord a, Binary a) => Binary (Set.Set a) where
put s = put (Set.size s) >> mapM_ put (Set.toAscList s)
get = liftM Set.fromDistinctAscList get
instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where
put m = put (Map.size m) >> mapM_ put (Map.toAscList m)
get = liftM Map.fromDistinctAscList get
instance Binary IntSet.IntSet where
put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)
get = liftM IntSet.fromDistinctAscList get
instance (Binary e) => Binary (IntMap.IntMap e) where
put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)
get = liftM IntMap.fromDistinctAscList get
------------------------------------------------------------------------
-- Floating point
-- instance Binary Double where
-- put d = put (decodeFloat d)
-- get = liftM2 encodeFloat get get
instance Binary Double where
put = putFloat64be
get = getFloat64be
{-
instance Binary Float where
put f = put (decodeFloat f)
get = liftM2 encodeFloat get get
-}
------------------------------------------------------------------------
-- Trees
{-
instance (Binary e) => Binary (T.Tree e) where
put (T.Node r s) = put r >> put s
get = liftM2 T.Node get get
-}
------------------------------------------------------------------------
-- Arrays
instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- write the length
mapM_ put (elems a) -- now the elems.
get = do
bs <- get
n <- get -- read the length
xs <- replicateM n get -- now the elems.
return (listArray bs xs)
--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- now write the length
mapM_ put (elems a)
get = do
bs <- get
n <- get
xs <- replicateM n get
return (listArray bs xs)

27
src/pgf-binary/pgf-binary.cabal
View File

@@ -1,27 +0,0 @@
name: pgf-binary
version: 0.5
cabal-version: >= 1.10
build-type: Simple
license: BSD3
--license-file: LICENSE
synopsis: Custom version of the binary-0.5 package for the PGF library
homepage: http://www.grammaticalframework.org/
--bug-reports: http://code.google.com/p/grammatical-framework/issues/list
maintainer: Thomas Hallgren
stability: provisional
category: Data, Parsing
tested-with: GHC==7.4.2, GHC==7.8.3
source-repository head
type: darcs
location: http://www.grammaticalframework.org/
Library
default-language: Haskell2010
build-depends: base >= 4.3 && <5, binary, data-binary-ieee754,
containers, array, bytestring
exposed-modules: PGF.Data.Binary
ghc-options: -fwarn-unused-imports -O2
extensions: FlexibleInstances, FlexibleContexts

1
src/runtime/c/Makefile.am
View File

@@ -68,6 +68,7 @@ libpgf_la_SOURCES = \
pgf/data.h \
pgf/expr.c \
pgf/expr.h \
pgf/scanner.c \
pgf/parser.c \
pgf/lookup.c \
pgf/jit.c \

10
src/runtime/c/gu/defs.h
View File

@@ -64,6 +64,8 @@
#ifdef GU_ALIGNOF
# define gu_alignof GU_ALIGNOF
#elif defined(_MSC_VER)
# define gu_alignof __alignof
#else
# define gu_alignof(t_) \
((size_t)(offsetof(struct { char c_; t_ e_; }, e_)))
@@ -77,7 +79,7 @@
#define GU_COMMA ,
#define GU_ARRAY_LEN(t,a) (sizeof((const t[])a) / sizeof(t))
#define GU_ARRAY_LEN(a) (sizeof(a) / sizeof(a[0]))
#define GU_ID(...) __VA_ARGS__
@@ -183,9 +185,13 @@ typedef union {
void (*fp)();
} GuMaxAlign;
#if defined(_MSC_VER)
#include <malloc.h>
#define gu_alloca(N) alloca(N)
#else
#define gu_alloca(N) \
(((union { GuMaxAlign align_; uint8_t buf_[N]; }){{0}}).buf_)
#endif
// For Doxygen
#define GU_PRIVATE /** @private */

156
src/runtime/c/gu/map.c
View File

@@ -7,6 +7,9 @@
typedef struct GuMapData GuMapData;
#define SKIP_DELETED 1
#define SKIP_NONE 2
struct GuMapData {
uint8_t* keys;
uint8_t* values;
@@ -19,6 +22,7 @@ struct GuMap {
GuHasher* hasher;
size_t key_size;
size_t value_size;
size_t cell_size; // cell_size = GU_MAX(value_size,sizeof(uint8_t))
const void* default_value;
GuMapData data;
@@ -30,9 +34,7 @@ gu_map_finalize(GuFinalizer* fin)
{
GuMap* map = gu_container(fin, GuMap, fin);
gu_mem_buf_free(map->data.keys);
if (map->value_size) {
gu_mem_buf_free(map->data.values);
}
gu_mem_buf_free(map->data.values);
}
static const GuWord gu_map_empty_key = 0;
@@ -68,7 +70,7 @@ gu_map_entry_is_free(GuMap* map, GuMapData* data, size_t idx)
}
static bool
gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
gu_map_lookup(GuMap* map, const void* key, uint8_t del, size_t* idx_out)
{
size_t n = map->data.n_entries;
if (map->hasher == gu_addr_hasher) {
@@ -78,13 +80,17 @@ gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
while (true) {
const void* entry_key =
((const void**)map->data.keys)[idx];
if (entry_key == NULL && map->data.zero_idx != idx) {
*idx_out = idx;
return false;
if (map->data.values[idx * map->cell_size] != del) { //skip deleted
*idx_out = idx;
return false;
}
} else if (entry_key == key) {
*idx_out = idx;
return true;
}
idx = (idx + offset) % n;
}
} else if (map->hasher == gu_word_hasher) {
@@ -156,33 +162,18 @@ gu_map_resize(GuMap* map, size_t req_entries)
size_t key_size = map->key_size;
size_t key_alloc = 0;
data->keys = gu_mem_buf_alloc(req_entries * key_size, &key_alloc);
memset(data->keys, 0, key_alloc);
size_t value_size = map->value_size;
size_t value_alloc = 0;
if (value_size) {
data->values = gu_mem_buf_alloc(req_entries * value_size,
&value_alloc);
memset(data->values, 0, value_alloc);
}
data->n_entries = gu_twin_prime_inf(value_size ?
GU_MIN(key_alloc / key_size,
value_alloc / value_size)
: key_alloc / key_size);
if (map->hasher == gu_addr_hasher) {
for (size_t i = 0; i < data->n_entries; i++) {
((const void**)data->keys)[i] = NULL;
}
} else if (map->hasher == gu_string_hasher) {
for (size_t i = 0; i < data->n_entries; i++) {
((GuString*)data->keys)[i] = NULL;
}
} else {
memset(data->keys, 0, key_alloc);
}
size_t cell_size = map->cell_size;
data->values = gu_mem_buf_alloc(req_entries * cell_size, &value_alloc);
memset(data->values, 0, value_alloc);
data->n_entries = gu_twin_prime_inf(
GU_MIN(key_alloc / key_size,
value_alloc / cell_size));
gu_assert(data->n_entries > data->n_occupied);
data->n_occupied = 0;
data->zero_idx = SIZE_MAX;
@@ -196,16 +187,14 @@ gu_map_resize(GuMap* map, size_t req_entries)
} else if (map->hasher == gu_string_hasher) {
old_key = (void*) *(GuString*)old_key;
}
void* old_value = &old_data.values[i * value_size];
void* old_value = &old_data.values[i * cell_size];
memcpy(gu_map_insert(map, old_key),
old_value, map->value_size);
}
gu_mem_buf_free(old_data.keys);
if (value_size) {
gu_mem_buf_free(old_data.values);
}
gu_mem_buf_free(old_data.values);
}
@@ -226,9 +215,9 @@ GU_API void*
gu_map_find(GuMap* map, const void* key)
{
size_t idx;
bool found = gu_map_lookup(map, key, &idx);
bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
if (found) {
return &map->data.values[idx * map->value_size];
return &map->data.values[idx * map->cell_size];
}
return NULL;
}
@@ -244,7 +233,7 @@ GU_API const void*
gu_map_find_key(GuMap* map, const void* key)
{
size_t idx;
bool found = gu_map_lookup(map, key, &idx);
bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
if (found) {
return &map->data.keys[idx * map->key_size];
}
@@ -255,17 +244,17 @@ GU_API bool
gu_map_has(GuMap* ht, const void* key)
{
size_t idx;
return gu_map_lookup(ht, key, &idx);
return gu_map_lookup(ht, key, SKIP_DELETED, &idx);
}
GU_API void*
gu_map_insert(GuMap* map, const void* key)
{
size_t idx;
bool found = gu_map_lookup(map, key, &idx);
bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
if (!found) {
if (gu_map_maybe_resize(map)) {
found = gu_map_lookup(map, key, &idx);
found = gu_map_lookup(map, key, SKIP_NONE, &idx);
gu_assert(!found);
}
if (map->hasher == gu_addr_hasher) {
@@ -277,7 +266,7 @@ gu_map_insert(GuMap* map, const void* key)
key, map->key_size);
}
if (map->default_value) {
memcpy(&map->data.values[idx * map->value_size],
memcpy(&map->data.values[idx * map->cell_size],
map->default_value, map->value_size);
}
if (gu_map_entry_is_free(map, &map->data, idx)) {
@@ -286,7 +275,32 @@ gu_map_insert(GuMap* map, const void* key)
}
map->data.n_occupied++;
}
return &map->data.values[idx * map->value_size];
return &map->data.values[idx * map->cell_size];
}
GU_API void
gu_map_delete(GuMap* map, const void* key)
{
size_t idx;
bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
if (found) {
if (map->hasher == gu_addr_hasher) {
((const void**)map->data.keys)[idx] = NULL;
} else if (map->hasher == gu_string_hasher) {
((GuString*)map->data.keys)[idx] = NULL;
} else {
memset(&map->data.keys[idx * map->key_size],
0, map->key_size);
}
map->data.values[idx * map->cell_size] = SKIP_DELETED;
if (gu_map_buf_is_zero(&map->data.keys[idx * map->key_size],
map->key_size)) {
map->data.zero_idx = SIZE_MAX;
}
map->data.n_occupied--;
}
}
GU_API void
@@ -297,7 +311,7 @@ gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
continue;
}
const void* key = &map->data.keys[i * map->key_size];
void* value = &map->data.values[i * map->value_size];
void* value = &map->data.values[i * map->cell_size];
if (map->hasher == gu_addr_hasher) {
key = *(const void* const*) key;
} else if (map->hasher == gu_string_hasher) {
@@ -307,47 +321,30 @@ gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
}
}
typedef struct {
GuEnum en;
GuMap* ht;
size_t i;
GuMapKeyValue x;
} GuMapEnum;
static void
gu_map_enum_next(GuEnum* self, void* to, GuPool* pool)
GU_API bool
gu_map_next(GuMap* map, size_t* pi, void** pkey, void* pvalue)
{
*((GuMapKeyValue**) to) = NULL;
size_t i;
GuMapEnum* en = (GuMapEnum*) self;
for (i = en->i; i < en->ht->data.n_entries; i++) {
if (gu_map_entry_is_free(en->ht, &en->ht->data, i)) {
while (*pi < map->data.n_entries) {
if (gu_map_entry_is_free(map, &map->data, *pi)) {
(*pi)++;
continue;
}
en->x.key = &en->ht->data.keys[i * en->ht->key_size];
en->x.value = &en->ht->data.values[i * en->ht->value_size];
if (en->ht->hasher == gu_addr_hasher) {
en->x.key = *(const void* const*) en->x.key;
} else if (en->ht->hasher == gu_string_hasher) {
en->x.key = *(GuString*) en->x.key;
*pkey = &map->data.keys[*pi * map->key_size];
if (map->hasher == gu_addr_hasher) {
*pkey = *(void**) *pkey;
} else if (map->hasher == gu_string_hasher) {
*pkey = *(void**) *pkey;
}
*((GuMapKeyValue**) to) = &en->x;
break;
}
en->i = i+1;
}
memcpy(pvalue, &map->data.values[*pi * map->cell_size],
map->value_size);
GU_API GuEnum*
gu_map_enum(GuMap* ht, GuPool* pool)
{
GuMapEnum* en = gu_new(GuMapEnum, pool);
en->en.next = gu_map_enum_next;
en->ht = ht;
en->i = 0;
return &en->en;
(*pi)++;
return true;
}
return false;
}
GU_API size_t
@@ -363,8 +360,6 @@ gu_map_count(GuMap* map)
return count;
}
static const uint8_t gu_map_no_values[1] = { 0 };
GU_API GuMap*
gu_make_map(size_t key_size, GuHasher* hasher,
size_t value_size, const void* default_value,
@@ -375,7 +370,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
.n_occupied = 0,
.n_entries = 0,
.keys = NULL,
.values = value_size ? NULL : (uint8_t*) gu_map_no_values,
.values = NULL,
.zero_idx = SIZE_MAX
};
GuMap* map = gu_new(GuMap, pool);
@@ -384,6 +379,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
map->data = data;
map->key_size = key_size;
map->value_size = value_size;
map->cell_size = GU_MAX(value_size,sizeof(uint8_t));
map->fin.fn = gu_map_finalize;
gu_pool_finally(pool, &map->fin);

12
src/runtime/c/gu/map.h
View File

@@ -62,6 +62,9 @@ gu_map_has(GuMap* ht, const void* key);
GU_API_DECL void*
gu_map_insert(GuMap* ht, const void* key);
GU_API_DECL void
gu_map_delete(GuMap* ht, const void* key);
#define gu_map_put(MAP, KEYP, V, VAL) \
GU_BEGIN \
V* gu_map_put_p_ = gu_map_insert((MAP), (KEYP)); \
@@ -71,13 +74,8 @@ gu_map_insert(GuMap* ht, const void* key);
GU_API_DECL void
gu_map_iter(GuMap* ht, GuMapItor* itor, GuExn* err);
typedef struct {
const void* key;
void* value;
} GuMapKeyValue;
GU_API_DECL GuEnum*
gu_map_enum(GuMap* ht, GuPool* pool);
GU_API bool
gu_map_next(GuMap* map, size_t* pi, void** pkey, void* pvalue);
typedef GuMap GuIntMap;

54
src/runtime/c/gu/mem.c
View File

@@ -8,6 +8,10 @@
#include <sys/mman.h>
#include <sys/stat.h>
#endif
#if defined(__MINGW32__) || defined(_MSC_VER)
#include <malloc.h>
#endif
#if !defined(_MSC_VER)
#include <unistd.h>
#endif
@@ -108,6 +112,39 @@ gu_mem_buf_alloc(size_t min_size, size_t* real_size_out)
return gu_mem_buf_realloc(NULL, min_size, real_size_out);
}
#if defined(__MINGW32__) || defined(_MSC_VER)
#include <windows.h>
static int
getpagesize()
{
SYSTEM_INFO system_info;
GetSystemInfo(&system_info);
return system_info.dwPageSize;
}
#endif
GU_API void*
gu_mem_page_alloc(size_t min_size, size_t* real_size_out)
{
size_t page_size = getpagesize();
size_t size = ((min_size + page_size - 1) / page_size) * page_size;
void *page = NULL;
#if defined(ANDROID)
if ((page = memalign(page_size, size)) == NULL) {
#elif defined(__MINGW32__) || defined(_MSC_VER)
if ((page = malloc(size)) == NULL) {
#else
if (posix_memalign(&page, page_size, size) != 0) {
#endif
gu_fatal("Memory allocation failed");
}
*real_size_out = size;
return page;
}
GU_API void
gu_mem_buf_free(void* buf)
{
@@ -132,6 +169,7 @@ struct GuFinalizerNode {
enum GuPoolType {
GU_POOL_HEAP,
GU_POOL_LOCAL,
GU_POOL_PAGE,
GU_POOL_MMAP
};
@@ -180,6 +218,16 @@ gu_new_pool(void)
return pool;
}
GU_API GuPool*
gu_new_page_pool(void)
{
size_t sz = GU_FLEX_SIZE(GuPool, init_buf, gu_mem_pool_initial_size);
uint8_t* buf = gu_mem_page_alloc(sz, &sz);
GuPool* pool = gu_init_pool(buf, sz);
pool->type = GU_POOL_PAGE;
return pool;
}
GU_API GuPool*
gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr)
{
@@ -238,7 +286,10 @@ gu_pool_expand(GuPool* pool, size_t req)
gu_mem_chunk_max_size));
gu_assert(real_req >= sizeof(GuMemChunk));
size_t size = 0;
GuMemChunk* chunk = gu_mem_buf_alloc(real_req, &size);
GuMemChunk* chunk =
(pool->type == GU_POOL_PAGE)
? gu_mem_page_alloc(real_req, &size)
: gu_mem_buf_alloc(real_req, &size);
chunk->next = pool->chunks;
pool->chunks = chunk;
pool->curr_buf = (uint8_t*) chunk;
@@ -309,6 +360,7 @@ gu_malloc_prefixed(GuPool* pool, size_t pre_align, size_t pre_size,
size_t full_size = gu_mem_advance(offsetof(GuMemChunk, data),
pre_align, pre_size, align, size);
if (full_size > gu_mem_max_shared_alloc &&
pool->type != GU_POOL_PAGE &&
pool->type != GU_POOL_MMAP) {
GuMemChunk* chunk = gu_mem_alloc(full_size);
chunk->next = pool->chunks;

8
src/runtime/c/gu/mem.h
View File

@@ -55,6 +55,11 @@ gu_local_pool_(uint8_t* init_buf, size_t sz);
* should not be used in the bodies of recursive functions.
*/
/// Create a pool where each chunk is corresponds to one or
/// more pages.
GU_API_DECL GuPool*
gu_new_page_pool(void);
/// Create a pool stored in a memory mapped file.
GU_API_DECL GuPool*
gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr);
@@ -198,6 +203,9 @@ gu_mem_buf_realloc(
size_t min_size,
size_t* real_size_out);
/// Allocate enough memory pages to contain min_size bytes.
GU_API_DECL void*
gu_mem_page_alloc(size_t min_size, size_t* real_size_out);
/// Free a memory buffer.
GU_API_DECL void

36
src/runtime/c/gu/seq.c
View File

@@ -100,6 +100,11 @@ gu_seq_free(GuSeq* seq)
gu_mem_buf_free(seq);
}
static void
gu_dummy_finalizer(GuFinalizer* self)
{
}
GU_API void
gu_buf_require(GuBuf* buf, size_t req_len)
{
@@ -109,7 +114,9 @@ gu_buf_require(GuBuf* buf, size_t req_len)
size_t req_size = sizeof(GuSeq) + buf->elem_size * req_len;
size_t real_size;
gu_require(buf->fin.fn != gu_dummy_finalizer);
if (buf->seq == NULL || buf->seq == gu_empty_seq()) {
buf->seq = gu_mem_buf_alloc(req_size, &real_size);
buf->seq->len = 0;
@@ -164,6 +171,24 @@ gu_buf_freeze(GuBuf* buf, GuPool* pool)
return seq;
}
GU_API void
gu_buf_evacuate(GuBuf* buf, GuPool* pool)
{
if (buf->seq != gu_empty_seq()) {
size_t len = gu_buf_length(buf);
GuSeq* seq = gu_make_seq(buf->elem_size, len, pool);
void* bufdata = gu_buf_data(buf);
void* seqdata = gu_seq_data(seq);
memcpy(seqdata, bufdata, buf->elem_size * len);
gu_mem_buf_free(buf->seq);
buf->seq = seq;
buf->fin.fn = gu_dummy_finalizer;
buf->avail_len = len;
}
}
GU_API void*
gu_buf_insert(GuBuf* buf, size_t index)
{
@@ -335,13 +360,8 @@ GU_API void
gu_buf_heap_pop(GuBuf *buf, GuOrder *order, void* data_out)
{
const void* last = gu_buf_trim(buf); // raises an error if empty
if (gu_buf_length(buf) > 0) {
memcpy(data_out, buf->seq->data, buf->elem_size);
gu_heap_siftup(buf, order, last, 0);
} else {
memcpy(data_out, last, buf->elem_size);
}
memcpy(data_out, buf->seq->data, buf->elem_size);
gu_heap_siftup(buf, order, last, 0);
}
GU_API void

3
src/runtime/c/gu/seq.h
View File

@@ -182,6 +182,9 @@ gu_buf_heapify(GuBuf *buf, GuOrder *order);
GU_API_DECL GuSeq*
gu_buf_freeze(GuBuf* buf, GuPool* pool);
GU_API_DECL void
gu_buf_evacuate(GuBuf* buf, GuPool* pool);
#endif // GU_SEQ_H_
#ifdef GU_STRING_H_

3
src/runtime/c/pgf/data.h
View File

@@ -344,8 +344,9 @@ struct PgfCCat {
PgfCncFuns* linrefs;
size_t n_synprods;
PgfProductionSeq* prods;
float viterbi_prob;
prob_t viterbi_prob;
int fid;
int chunk_count;
PgfItemConts* conts;
struct PgfAnswers* answers;
GuFinalizer fin[0];

8
src/runtime/c/pgf/expr.h
View File

@@ -198,16 +198,16 @@ pgf_literal_hash(GuHash h, PgfLiteral lit);
PGF_API_DECL GuHash
pgf_expr_hash(GuHash h, PgfExpr e);
PGF_API size_t
PGF_API_DECL size_t
pgf_expr_size(PgfExpr expr);
PGF_API GuSeq*
PGF_API_DECL GuSeq*
pgf_expr_functions(PgfExpr expr, GuPool* pool);
PGF_API PgfExpr
PGF_API_DECL PgfExpr
pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool);
PGF_API PgfType*
PGF_API_DECL PgfType*
pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool);
typedef struct PgfPrintContext PgfPrintContext;

30
src/runtime/c/pgf/jit.c
View File

@@ -5,9 +5,6 @@
#include <pgf/reasoner.h>
#include <pgf/reader.h>
#include "lightning.h"
#if defined(__MINGW32__) || defined(_MSC_VER)
#include <malloc.h>
#endif
//#define PGF_JIT_DEBUG
@@ -43,18 +40,6 @@ typedef struct {
#define JIT_VSTATE JIT_V1
#define JIT_VCLOS JIT_V2
#if defined(__MINGW32__) || defined(_MSC_VER)
#include <windows.h>
static int
getpagesize()
{
SYSTEM_INFO system_info;
GetSystemInfo(&system_info);
return system_info.dwPageSize;
}
#endif
static void
pgf_jit_finalize_page(GuFinalizer* self)
@@ -65,19 +50,8 @@ pgf_jit_finalize_page(GuFinalizer* self)
static void
pgf_jit_alloc_page(PgfReader* rdr)
{
void *page;
size_t page_size = getpagesize();
#if defined(ANDROID)
if ((page = memalign(page_size, page_size)) == NULL) {
#elif defined(__MINGW32__) || defined(_MSC_VER)
if ((page = malloc(page_size)) == NULL) {
#else
if (posix_memalign(&page, page_size, page_size) != 0) {
#endif
gu_fatal("Memory allocation failed");
}
size_t page_size;
void *page = gu_mem_page_alloc(sizeof(GuFinalizer), &page_size);
GuFinalizer* fin = page;
fin->fn = pgf_jit_finalize_page;

1173
src/runtime/c/pgf/parser.c
View File

File diff suppressed because it is too large Load Diff

16
src/runtime/c/pgf/pgf.h
View File

@@ -162,6 +162,22 @@ PGF_API_DECL void
pgf_lookup_morpho(PgfConcr *concr, GuString sentence,
PgfMorphoCallback* callback, GuExn* err);
typedef struct {
size_t pos;
GuString ptr;
} PgfCohortSpot;
typedef struct {
PgfCohortSpot start;
PgfCohortSpot end;
GuBuf* buf;
} PgfCohortRange;
PGF_API_DECL GuEnum*
pgf_lookup_cohorts(PgfConcr *concr, GuString sentence,
PgfMorphoCallback* callback,
GuPool* pool, GuExn* err);
typedef struct PgfFullFormEntry PgfFullFormEntry;
PGF_API_DECL GuEnum*

111
src/runtime/c/pgf/printer.c
View File

@@ -98,6 +98,74 @@ pgf_print_fid(int fid, GuOut* out, GuExn* err)
gu_printf(out, err, "C%d", fid);
}
PGF_INTERNAL void
pgf_print_production_args(PgfPArgs* args,
GuOut* out, GuExn* err)
{
size_t n_args = gu_seq_length(args);
for (size_t j = 0; j < n_args; j++) {
if (j > 0)
gu_putc(',',out,err);
PgfPArg arg = gu_seq_get(args, PgfPArg, j);
if (arg.hypos != NULL &&
gu_seq_length(arg.hypos) > 0) {
size_t n_hypos = gu_seq_length(arg.hypos);
for (size_t k = 0; k < n_hypos; k++) {
PgfCCat *hypo = gu_seq_get(arg.hypos, PgfCCat*, k);
pgf_print_fid(hypo->fid, out, err);
gu_putc(' ',out,err);
}
gu_puts("-> ",out,err);
}
pgf_print_fid(arg.ccat->fid, out, err);
}
}
PGF_INTERNAL void
pgf_print_production(int fid, PgfProduction prod,
GuOut *out, GuExn* err)
{
pgf_print_fid(fid, out, err);
gu_puts(" -> ", out, err);
GuVariantInfo i = gu_variant_open(prod);
switch (i.tag) {
case PGF_PRODUCTION_APPLY: {
PgfProductionApply* papp = i.data;
gu_printf(out,err,"F%d(",papp->fun->funid);
if (papp->fun->ep != NULL) {
pgf_print_expr(papp->fun->ep->expr, NULL, 0, out, err);
} else {
PgfPArg* parg = gu_seq_index(papp->args, PgfPArg, 0);
gu_printf(out,err,"linref %s", parg->ccat->cnccat->abscat->name);
}
gu_printf(out,err,")[");
pgf_print_production_args(papp->args,out,err);
gu_printf(out,err,"]\n");
break;
}
case PGF_PRODUCTION_COERCE: {
PgfProductionCoerce* pcoerce = i.data;
gu_puts("_[",out,err);
pgf_print_fid(pcoerce->coerce->fid, out, err);
gu_puts("]\n",out,err);
break;
}
case PGF_PRODUCTION_EXTERN: {
PgfProductionExtern* pext = i.data;
gu_printf(out,err,"<extern>(");
pgf_print_expr(pext->ep->expr, NULL, 0, out, err);
gu_printf(out,err,")[]\n");
break;
}
default:
gu_impossible();
}
}
static void
pgf_print_productions(GuMapItor* fn, const void* key, void* value,
GuExn* err)
@@ -111,48 +179,7 @@ pgf_print_productions(GuMapItor* fn, const void* key, void* value,
size_t n_prods = gu_seq_length(ccat->prods);
for (size_t i = 0; i < n_prods; i++) {
PgfProduction prod = gu_seq_get(ccat->prods, PgfProduction, i);
gu_puts(" ", out, err);
pgf_print_fid(fid, out, err);
gu_puts(" -> ", out, err);
GuVariantInfo i = gu_variant_open(prod);
switch (i.tag) {
case PGF_PRODUCTION_APPLY: {
PgfProductionApply* papp = i.data;
gu_printf(out,err,"F%d[",papp->fun->funid);
size_t n_args = gu_seq_length(papp->args);
for (size_t j = 0; j < n_args; j++) {
if (j > 0)
gu_putc(',',out,err);
PgfPArg arg = gu_seq_get(papp->args, PgfPArg, j);
if (arg.hypos != NULL) {
size_t n_hypos = gu_seq_length(arg.hypos);
for (size_t k = 0; k < n_hypos; k++) {
if (k > 0)
gu_putc(' ',out,err);
PgfCCat *hypo = gu_seq_get(arg.hypos, PgfCCat*, k);
pgf_print_fid(hypo->fid, out, err);
}
}
pgf_print_fid(arg.ccat->fid, out, err);
}
gu_printf(out,err,"]\n");
break;
}
case PGF_PRODUCTION_COERCE: {
PgfProductionCoerce* pcoerce = i.data;
gu_puts("_[", out, err);
pgf_print_fid(pcoerce->coerce->fid, out, err);
gu_puts("]\n", out, err);
break;
}
default:
gu_impossible();
}
pgf_print_production(fid, prod, out, err);
}
}
}

24
src/runtime/c/pgf/reader.c
View File

@@ -328,16 +328,20 @@ pgf_read_patt(PgfReader* rdr)
uint8_t tag = pgf_read_tag(rdr);
switch (tag) {
case PGF_PATT_APP: {
PgfCId ctor = pgf_read_cid(rdr, rdr->opool);
gu_return_on_exn(rdr->err, gu_null_variant);
size_t n_args = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, gu_null_variant);
PgfPattApp *papp =
gu_new_variant(PGF_PATT_APP,
PgfPattApp,
&patt, rdr->opool);
papp->ctor = pgf_read_cid(rdr, rdr->opool);
gu_return_on_exn(rdr->err, gu_null_variant);
papp->n_args = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, gu_null_variant);
gu_new_flex_variant(PGF_PATT_APP,
PgfPattApp,
args, n_args,
&patt, rdr->opool);
papp->ctor = ctor;
papp->n_args = n_args;
for (size_t i = 0; i < papp->n_args; i++) {
papp->args[i] = pgf_read_patt(rdr);
gu_return_on_exn(rdr->err, gu_null_variant);
@@ -840,6 +844,7 @@ pgf_read_fid(PgfReader* rdr, PgfConcr* concr)
ccat->prods = NULL;
ccat->viterbi_prob = 0;
ccat->fid = fid;
ccat->chunk_count = 1;
ccat->conts = NULL;
ccat->answers = NULL;
@@ -1077,6 +1082,7 @@ pgf_read_cnccat(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, PgfCId name)
ccat->prods = NULL;
ccat->viterbi_prob = 0;
ccat->fid = fid;
ccat->chunk_count = 1;
ccat->conts = NULL;
ccat->answers = NULL;

516
src/runtime/c/pgf/scanner.c Normal file
View File

@@ -0,0 +1,516 @@
#include <pgf/data.h>
#include <pgf/expr.h>
#include <pgf/linearizer.h>
#include <gu/utf8.h>
PGF_INTERNAL int
cmp_string(PgfCohortSpot* spot, GuString tok,
bool case_sensitive)
{
for (;;) {
GuUCS c2 = gu_utf8_decode((const uint8_t**) &tok);
if (c2 == 0)
return 0;
const uint8_t* p = (uint8_t*) spot->ptr;
GuUCS c1 = gu_utf8_decode(&p);
if (c1 == 0)
return -1;
if (!case_sensitive) {
c1 = gu_ucs_to_lower(c1);
c2 = gu_ucs_to_lower(c2);
}
if (c1 != c2)
return (c1-c2);
spot->ptr = (GuString) p;
spot->pos++;
}
}
PGF_INTERNAL bool
skip_space(GuString* psent, size_t* ppos)
{
const uint8_t* p = (uint8_t*) *psent;
if (!gu_ucs_is_space(gu_utf8_decode(&p)))
return false;
*psent = (GuString) p;
(*ppos)++;
return true;
}
PGF_INTERNAL int
pgf_symbols_cmp(PgfCohortSpot* spot,
PgfSymbols* syms, size_t* sym_idx,
bool case_sensitive)
{
size_t n_syms = gu_seq_length(syms);
while (*sym_idx < n_syms) {
PgfSymbol sym = gu_seq_get(syms, PgfSymbol, *sym_idx);
if (*sym_idx > 0) {
if (!skip_space(&spot->ptr,&spot->pos)) {
if (*spot->ptr == 0)
return -1;
return 1;
}
while (*spot->ptr != 0) {
if (!skip_space(&spot->ptr,&spot->pos))
break;
}
}
GuVariantInfo inf = gu_variant_open(sym);
switch (inf.tag) {
case PGF_SYMBOL_CAT:
case PGF_SYMBOL_LIT:
case PGF_SYMBOL_VAR: {
if (*spot->ptr == 0)
return -1;
return 1;
}
case PGF_SYMBOL_KS: {
PgfSymbolKS* pks = inf.data;
if (*spot->ptr == 0)
return -1;
int cmp = cmp_string(spot,pks->token, case_sensitive);
if (cmp != 0)
return cmp;
break;
}
case PGF_SYMBOL_KP:
case PGF_SYMBOL_BIND:
case PGF_SYMBOL_NE:
case PGF_SYMBOL_SOFT_BIND:
case PGF_SYMBOL_SOFT_SPACE:
case PGF_SYMBOL_CAPIT:
case PGF_SYMBOL_ALL_CAPIT: {
return -1;
}
default:
gu_impossible();
}
(*sym_idx)++;
}
return 0;
}
static void
pgf_morpho_iter(PgfProductionIdx* idx,
PgfMorphoCallback* callback,
GuExn* err)
{
size_t n_entries = gu_buf_length(idx);
for (size_t i = 0; i < n_entries; i++) {
PgfProductionIdxEntry* entry =
gu_buf_index(idx, PgfProductionIdxEntry, i);
PgfCId lemma = entry->papp->fun->absfun->name;
GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
prob_t prob = entry->ccat->cnccat->abscat->prob +
entry->papp->fun->absfun->ep.prob;
callback->callback(callback,
lemma, analysis, prob, err);
if (!gu_ok(err))
return;
}
}
typedef struct {
GuOrder order;
bool case_sensitive;
} PgfSequenceOrder;
PGF_INTERNAL bool
pgf_is_case_sensitive(PgfConcr* concr)
{
PgfFlag* flag =
gu_seq_binsearch(concr->cflags, pgf_flag_order, PgfFlag, "case_sensitive");
if (flag != NULL) {
GuVariantInfo inf = gu_variant_open(flag->value);
if (inf.tag == PGF_LITERAL_STR) {
PgfLiteralStr* lstr = inf.data;
if (strcmp(lstr->val, "off") == 0)
return false;
}
}
return true;
}
static int
pgf_sequence_cmp_fn(GuOrder* order, const void* p1, const void* p2)
{
PgfSequenceOrder* self = gu_container(order, PgfSequenceOrder, order);
PgfCohortSpot spot = {0, (GuString) p1};
const PgfSequence* sp2 = p2;
size_t sym_idx = 0;
int res = pgf_symbols_cmp(&spot, sp2->syms, &sym_idx, self->case_sensitive);
if (res == 0 && (*spot.ptr != 0 || sym_idx != gu_seq_length(sp2->syms))) {
res = 1;
}
return res;
}
PGF_API void
pgf_lookup_morpho(PgfConcr *concr, GuString sentence,
PgfMorphoCallback* callback, GuExn* err)
{
if (concr->sequences == NULL) {
GuExnData* err_data = gu_raise(err, PgfExn);
if (err_data) {
err_data->data = "The concrete syntax is not loaded";
return;
}
}
size_t index = 0;
PgfSequenceOrder order = { { pgf_sequence_cmp_fn },
pgf_is_case_sensitive(concr) };
if (gu_seq_binsearch_index(concr->sequences, &order.order,
PgfSequence, (void*) sentence,
&index)) {
PgfSequence* seq = NULL;
/* If the match is case-insensitive then there might be more
* matches around the current index. We must check the neighbour
* sequences for matching as well.
*/
if (!order.case_sensitive) {
size_t i = index;
while (i > 0) {
seq = gu_seq_index(concr->sequences, PgfSequence, i-1);
size_t sym_idx = 0;
PgfCohortSpot spot = {0, sentence};
if (pgf_symbols_cmp(&spot, seq->syms, &sym_idx, order.case_sensitive) != 0) {
break;
}
if (seq->idx != NULL)
pgf_morpho_iter(seq->idx, callback, err);
i--;
}
}
seq = gu_seq_index(concr->sequences, PgfSequence, index);
if (seq->idx != NULL)
pgf_morpho_iter(seq->idx, callback, err);
if (!order.case_sensitive) {
size_t i = index+1;
while (i < gu_seq_length(concr->sequences)) {
seq = gu_seq_index(concr->sequences, PgfSequence, i);
size_t sym_idx = 0;
PgfCohortSpot spot = {0, sentence};
if (pgf_symbols_cmp(&spot, seq->syms, &sym_idx, order.case_sensitive) != 0) {
break;
}
if (seq->idx != NULL)
pgf_morpho_iter(seq->idx, callback, err);
i++;
}
}
}
}
typedef struct {
GuEnum en;
PgfConcr* concr;
GuString sentence;
GuString current;
size_t len;
PgfMorphoCallback* callback;
GuExn* err;
bool case_sensitive;
GuBuf* spots;
GuBuf* found;
} PgfCohortsState;
static int
cmp_cohort_spot(GuOrder* self, const void* a, const void* b)
{
PgfCohortSpot *s1 = (PgfCohortSpot *) a;
PgfCohortSpot *s2 = (PgfCohortSpot *) b;
return (s1->ptr-s2->ptr);
}
static GuOrder
pgf_cohort_spot_order[1] = {{ cmp_cohort_spot }};
static void
pgf_lookup_cohorts_helper(PgfCohortsState *state, PgfCohortSpot* spot,
int i, int j, ptrdiff_t min, ptrdiff_t max)
{
// This is a variation of a binary search algorithm which
// can retrieve all prefixes of a string with minimal
// comparisons, i.e. there is no need to lookup every
// prefix separately.
while (i <= j) {
int k = (i+j) / 2;
PgfSequence* seq = gu_seq_index(state->concr->sequences, PgfSequence, k);
PgfCohortSpot current = *spot;
size_t sym_idx = 0;
int cmp = pgf_symbols_cmp(&current, seq->syms, &sym_idx, state->case_sensitive);
if (cmp < 0) {
j = k-1;
} else if (cmp > 0) {
ptrdiff_t len = current.ptr - spot->ptr;
if (min <= len)
pgf_lookup_cohorts_helper(state, spot, i, k-1, min, len);
if (len+1 <= max)
pgf_lookup_cohorts_helper(state, spot, k+1, j, len+1, max);
break;
} else {
ptrdiff_t len = current.ptr - spot->ptr;
if (min <= len)
pgf_lookup_cohorts_helper(state, spot, i, k-1, min, len);
if (seq->idx != NULL && gu_buf_length(seq->idx) > 0) {
PgfCohortRange* range = gu_buf_insert(state->found, 0);
range->start = *spot;
range->end = current;
range->buf = seq->idx;
}
while (*current.ptr != 0) {
if (!skip_space(&current.ptr, &current.pos))
break;
}
gu_buf_heap_push(state->spots, pgf_cohort_spot_order, &current);
if (len <= max)
pgf_lookup_cohorts_helper(state, spot, k+1, j, len, max);
break;
}
}
}
static void
pgf_lookup_cohorts_enum_next(GuEnum* self, void* to, GuPool* pool)
{
PgfCohortsState* state = gu_container(self, PgfCohortsState, en);
while (gu_buf_length(state->found) == 0 &&
gu_buf_length(state->spots) > 0) {
PgfCohortSpot spot;
gu_buf_heap_pop(state->spots, pgf_cohort_spot_order, &spot);
if (spot.ptr == state->current)
continue;
if (*spot.ptr == 0)
break;
pgf_lookup_cohorts_helper
(state, &spot,
0, gu_seq_length(state->concr->sequences)-1,
1, (state->sentence+state->len)-spot.ptr);
if (gu_buf_length(state->found) == 0) {
// skip one character and try again
gu_utf8_decode((const uint8_t**) &spot.ptr);
spot.pos++;
gu_buf_heap_push(state->spots, pgf_cohort_spot_order, &spot);
}
}
PgfCohortRange* pRes = (PgfCohortRange*)to;
if (gu_buf_length(state->found) == 0) {
pRes->start.pos = 0;
pRes->start.ptr = NULL;
pRes->end.pos = 0;
pRes->end.ptr = NULL;
pRes->buf = NULL;
state->current = NULL;
return;
} else do {
*pRes = gu_buf_pop(state->found, PgfCohortRange);
state->current = pRes->start.ptr;
pgf_morpho_iter(pRes->buf, state->callback, state->err);
} while (gu_buf_length(state->found) > 0 &&
gu_buf_index_last(state->found, PgfCohortRange)->end.ptr == pRes->end.ptr);
}
PGF_API GuEnum*
pgf_lookup_cohorts(PgfConcr *concr, GuString sentence,
PgfMorphoCallback* callback,
GuPool* pool, GuExn* err)
{
if (concr->sequences == NULL) {
GuExnData* err_data = gu_raise(err, PgfExn);
if (err_data) {
err_data->data = "The concrete syntax is not loaded";
return NULL;
}
}
PgfCohortsState* state = gu_new(PgfCohortsState, pool);
state->en.next = pgf_lookup_cohorts_enum_next;
state->concr = concr;
state->sentence= sentence;
state->len = strlen(sentence);
state->callback= callback;
state->err = err;
state->case_sensitive = pgf_is_case_sensitive(concr);
state->spots = gu_new_buf(PgfCohortSpot, pool);
state->found = gu_new_buf(PgfCohortRange, pool);
PgfCohortSpot spot = {0,sentence};
while (*spot.ptr != 0) {
if (!skip_space(&spot.ptr, &spot.pos))
break;
}
gu_buf_heap_push(state->spots, pgf_cohort_spot_order, &spot);
return &state->en;
}
typedef struct {
GuEnum en;
PgfSequences* sequences;
GuString prefix;
size_t seq_idx;
bool case_sensitive;
} PgfFullFormState;
struct PgfFullFormEntry {
GuString tokens;
PgfProductionIdx* idx;
};
static void
gu_fullform_enum_next(GuEnum* self, void* to, GuPool* pool)
{
PgfFullFormState* st = gu_container(self, PgfFullFormState, en);
PgfFullFormEntry* entry = NULL;
if (st->sequences != NULL) {
size_t n_seqs = gu_seq_length(st->sequences);
while (st->seq_idx < n_seqs) {
PgfSequence* seq = gu_seq_index(st->sequences, PgfSequence, st->seq_idx);
GuString tokens = pgf_get_tokens(seq->syms, 0, pool);
PgfCohortSpot spot = {0, st->prefix};
if (cmp_string(&spot, tokens, st->case_sensitive) > 0 || *spot.ptr != 0) {
st->seq_idx = n_seqs;
break;
}
if (*tokens != 0 && seq->idx != NULL) {
entry = gu_new(PgfFullFormEntry, pool);
entry->tokens = tokens;
entry->idx = seq->idx;
st->seq_idx++;
break;
}
st->seq_idx++;
}
}
*((PgfFullFormEntry**) to) = entry;
}
PGF_API GuEnum*
pgf_fullform_lexicon(PgfConcr *concr, GuPool* pool)
{
PgfFullFormState* st = gu_new(PgfFullFormState, pool);
st->en.next = gu_fullform_enum_next;
st->sequences = concr->sequences;
st->prefix = "";
st->seq_idx = 0;
st->case_sensitive = true;
return &st->en;
}
PGF_API GuString
pgf_fullform_get_string(PgfFullFormEntry* entry)
{
return entry->tokens;
}
PGF_API void
pgf_fullform_get_analyses(PgfFullFormEntry* entry,
PgfMorphoCallback* callback, GuExn* err)
{
pgf_morpho_iter(entry->idx, callback, err);
}
PGF_API GuEnum*
pgf_lookup_word_prefix(PgfConcr *concr, GuString prefix,
GuPool* pool, GuExn* err)
{
if (concr->sequences == NULL) {
GuExnData* err_data = gu_raise(err, PgfExn);
if (err_data) {
err_data->data = "The concrete syntax is not loaded";
return NULL;
}
}
PgfFullFormState* state = gu_new(PgfFullFormState, pool);
state->en.next = gu_fullform_enum_next;
state->sequences = concr->sequences;
state->prefix = prefix;
state->seq_idx = 0;
state->case_sensitive = pgf_is_case_sensitive(concr);
PgfSequenceOrder order = { { pgf_sequence_cmp_fn },
state->case_sensitive };
if (!gu_seq_binsearch_index(concr->sequences, &order.order,
PgfSequence, (void*) prefix,
&state->seq_idx)) {
state->seq_idx++;
} else if (!state->case_sensitive) {
/* If the match is case-insensitive then there might be more
* matches around the current index. Since we scroll down
* anyway, it is enough to search upwards now.
*/
while (state->seq_idx > 0) {
PgfSequence* seq =
gu_seq_index(concr->sequences, PgfSequence, state->seq_idx-1);
size_t sym_idx = 0;
PgfCohortSpot spot = {0, state->prefix};
if (pgf_symbols_cmp(&spot, seq->syms, &sym_idx, state->case_sensitive) > 0 || *spot.ptr != 0) {
break;
}
state->seq_idx--;
}
}
return &state->en;
}

9
src/runtime/c/sg/sg.c
View File

@@ -499,14 +499,17 @@ store_expr(SgSG* sg,
PgfExprLit* elit = ei.data;
Mem mem[2];
size_t len = 0;
GuVariantInfo li = gu_variant_open(elit->lit);
switch (li.tag) {
case PGF_LITERAL_STR: {
PgfLiteralStr* lstr = li.data;
len = strlen(lstr->val);
mem[0].flags = MEM_Str;
mem[0].n = strlen(lstr->val);
mem[0].n = len;
mem[0].z = lstr->val;
break;
}
@@ -515,6 +518,7 @@ store_expr(SgSG* sg,
mem[0].flags = MEM_Int;
mem[0].u.i = lint->val;
len = sizeof(mem[0].u.i);
break;
}
case PGF_LITERAL_FLT: {
@@ -522,6 +526,7 @@ store_expr(SgSG* sg,
mem[0].flags = MEM_Real;
mem[0].u.r = lflt->val;
len = sizeof(mem[0].u.r);
break;
}
default:
@@ -556,7 +561,7 @@ store_expr(SgSG* sg,
int serial_type_arg = sqlite3BtreeSerialType(&mem[1], file_format);
int serial_type_arg_hdr_len = sqlite3BtreeVarintLen(serial_type_arg);
unsigned char* buf = malloc(1+serial_type_lit_hdr_len+(serial_type_arg_hdr_len > 1 ? serial_type_arg_hdr_len : 1)+mem[0].n+8);
unsigned char* buf = malloc(1+serial_type_lit_hdr_len+(serial_type_arg_hdr_len > 1 ? serial_type_arg_hdr_len : 1)+len+8);
unsigned char* p = buf;
*p++ = 1+serial_type_lit_hdr_len+serial_type_arg_hdr_len;
p += putVarint32(p, serial_type_lit);

1
src/runtime/c/sg/sqlite3Btree.c
View File

@@ -4835,7 +4835,6 @@ SQLITE_PRIVATE int sqlite3HeaderSizeBtree(void);
SQLITE_PRIVATE void sqlite3VdbeRecordUnpack(KeyInfo*,int,const void*,UnpackedRecord*);
SQLITE_PRIVATE UnpackedRecord *sqlite3VdbeAllocUnpackedRecord(KeyInfo *, char *, int, char **);
typedef int (*RecordCompare)(int,const void*,UnpackedRecord*);
SQLITE_PRIVATE RecordCompare sqlite3VdbeFindCompare(UnpackedRecord*);
/************** End of btreeInt.h ********************************************/

72
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -66,7 +66,7 @@ module PGF2 (-- * PGF
-- ** Generation
generateAll,
-- ** Morphological Analysis
MorphoAnalysis, lookupMorpho, fullFormLexicon,
MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
-- ** Visualizations
GraphvizOptions(..), graphvizDefaults,
graphvizAbstractTree, graphvizParseTree,
@@ -168,8 +168,6 @@ showPGF p =
languages :: PGF -> Map.Map ConcName Concr
languages p = langs p
-- | The abstract language name is the name of the top-level
-- abstract module
concreteName :: Concr -> ConcName
concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c))
@@ -893,8 +891,23 @@ newGraphvizOptions pool opts = do
-- Functions using Concr
-- Morpho analyses, parsing & linearization
type MorphoAnalysis = (Fun,Cat,Float)
-- | 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 (Concr concr master) sent =
unsafePerformIO $
@@ -908,6 +921,45 @@ lookupMorpho (Concr concr master) sent =
freeHaskellFunPtr fptr
readIORef ref
-- | '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,[MorphoAnalysis],Int)]
lookupCohorts lang@(Concr concr master) sent =
unsafePerformIO $
do pl <- gu_new_pool
ref <- newIORef []
cback <- gu_malloc pl (#size PgfMorphoCallback)
fptr <- wrapLookupMorphoCallback (getAnalysis ref)
(#poke PgfMorphoCallback, callback) cback fptr
c_sent <- newUtf8CString sent pl
enum <- pgf_lookup_cohorts concr c_sent cback pl nullPtr
fpl <- newForeignPtr gu_pool_finalizer pl
fromCohortRange enum fpl fptr ref
where
fromCohortRange enum fpl fptr ref =
allocaBytes (#size PgfCohortRange) $ \ptr ->
withForeignPtr fpl $ \pl ->
do gu_enum_next enum ptr pl
buf <- (#peek PgfCohortRange, buf) ptr
if buf == nullPtr
then do finalizeForeignPtr fpl
freeHaskellFunPtr fptr
touchConcr lang
return []
else do start <- (#peek PgfCohortRange, start.pos) ptr
end <- (#peek PgfCohortRange, end.pos) ptr
ans <- readIORef ref
writeIORef ref []
cohs <- unsafeInterleaveIO (fromCohortRange enum fpl fptr ref)
return ((start,ans,end):cohs)
fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])]
fullFormLexicon lang =
unsafePerformIO $
@@ -1393,11 +1445,13 @@ bracketedLinearize lang e = unsafePerformIO $
end_phrase ref _ c_cat c_fid c_lindex c_fun = do
(bs':stack,bs) <- readIORef ref
cat <- peekUtf8CString c_cat
let fid = fromIntegral c_fid
let lindex = fromIntegral c_lindex
fun <- peekUtf8CString c_fun
writeIORef ref (stack, Bracket cat fid lindex fun (reverse bs) : bs')
if null bs
then writeIORef ref (stack, bs')
else do cat <- peekUtf8CString c_cat
let fid = fromIntegral c_fid
let lindex = fromIntegral c_lindex
fun <- peekUtf8CString c_fun
writeIORef ref (stack, Bracket cat fid lindex fun (reverse bs) : bs')
symbol_ne exn _ = do
gu_exn_raise exn gu_exn_type_PgfLinNonExist

16
src/runtime/haskell-bind/PGF2/Expr.hsc
View File

@@ -6,7 +6,9 @@ import System.IO.Unsafe(unsafePerformIO)
import Foreign hiding (unsafePerformIO)
import Foreign.C
import Data.IORef
import Data.Data
import PGF2.FFI
import Data.Maybe(fromJust)
type Cat = String -- ^ Name of syntactic category
type Fun = String -- ^ Name of function
@@ -36,6 +38,20 @@ instance Eq Expr where
e1_touch >> e2_touch
return (res /= 0)
instance Data Expr where
gfoldl f z e = z (fromJust . readExpr) `f` (showExpr [] e)
toConstr _ = readExprConstr
gunfold k z c = case constrIndex c of
1 -> k (z (fromJust . readExpr))
_ -> error "gunfold"
dataTypeOf _ = exprDataType
readExprConstr :: Constr
readExprConstr = mkConstr exprDataType "(fromJust . readExpr)" [] Prefix
exprDataType :: DataType
exprDataType = mkDataType "PGF2.Expr" [readExprConstr]
-- | Constructs an expression by lambda abstraction
mkAbs :: BindType -> String -> Expr -> Expr
mkAbs bind_type var (Expr body bodyTouch) =

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

@@ -100,7 +100,7 @@ foreign import ccall unsafe "gu/string.h gu_string_buf_out"
foreign import ccall unsafe "gu/file.h gu_file_in"
gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
foreign import ccall unsafe "gu/enum.h gu_enum_next"
foreign import ccall safe "gu/enum.h gu_enum_next"
gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
@@ -409,6 +409,9 @@ foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_lookup_cohorts"
pgf_lookup_cohorts :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuEnum)
type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO ()
foreign import ccall "wrapper"

25
src/runtime/haskell-bind/PGF2/Internal.hsc
View File

@@ -16,6 +16,9 @@ module PGF2.Internal(-- * Access the internal structures
eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo,
AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
-- * Expose PGF and Concr for FFI with C
PGF(..), Concr(..),
-- * Write an in-memory PGF to a file
unionPGF, writePGF, writeConcr,
@@ -592,17 +595,17 @@ newAbstr aflags cats funs = unsafePerformIO $ do
data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt
newConcr :: (?builder :: Builder s) => B s AbstrInfo ->
[(String,Literal)] -> -- ^ Concrete syntax flags
[(String,String)] -> -- ^ Printnames
[(FId,[FunId])] -> -- ^ Lindefs
[(FId,[FunId])] -> -- ^ Linrefs
[(FId,[Production])] -> -- ^ Productions
[(Fun,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun)
[[Symbol]] -> -- ^ Sequences (must be sorted)
[(Cat,FId,FId,[String])] -> -- ^ Concrete categories
FId -> -- ^ The total count of the categories
B s ConcrInfo
newConcr :: (?builder :: Builder s) => B s AbstrInfo
-> [(String,Literal)] -- ^ Concrete syntax flags
-> [(String,String)] -- ^ Printnames
-> [(FId,[FunId])] -- ^ Lindefs
-> [(FId,[FunId])] -- ^ Linrefs
-> [(FId,[Production])] -- ^ Productions
-> [(Fun,[SeqId])] -- ^ Concrete functions (must be sorted by Fun)
-> [[Symbol]] -- ^ Sequences (must be sorted)
-> [(Cat,FId,FId,[String])] -- ^ Concrete categories
-> FId -- ^ The total count of the categories
-> B s ConcrInfo
newConcr (B (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _)) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
c_cflags <- newFlags cflags pool
c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString

4
src/runtime/haskell-bind/utils.c
View File

@@ -100,7 +100,7 @@ hspgf_predict_callback(PgfOracleCallback* self,
size_t offset)
{
HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset));
return oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset));
}
static bool
@@ -110,7 +110,7 @@ hspgf_complete_callback(PgfOracleCallback* self,
size_t offset)
{
HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset));
return oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset));
}
static PgfExprProb*

2
src/runtime/haskell/PGF.hs
View File

@@ -371,7 +371,7 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
(producers,consumers) = Map.foldrWithKey accum ([],[]) (funs (abstract pgf))
where
accum f (ty,_,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist

6
src/runtime/haskell/PGF/Forest.hs
View File

@@ -58,8 +58,8 @@ bracketedTokn :: Maybe Int -> Forest -> BracketedTokn
bracketedTokn dp f@(Forest abs cnc forest root) =
case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of
([bs@(Bracket_{})]:_) -> bs
(bss:_) -> Bracket_ wildCId 0 0 wildCId [] bss
[] -> Bracket_ wildCId 0 0 wildCId [] []
(bss:_) -> Bracket_ wildCId 0 0 0 wildCId [] bss
[] -> Bracket_ wildCId 0 0 0 wildCId [] []
where
isTrusted (_,fid) = IntSet.member fid trusted
@@ -190,7 +190,7 @@ foldForest :: (FunId -> [PArg] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -
foldForest f g b fcat forest =
case IntMap.lookup fcat forest of
Nothing -> b
Just set -> Set.fold foldProd b set
Just set -> Set.foldr foldProd b set
where
foldProd (PCoerce fcat) b = foldForest f g b fcat forest
foldProd (PApply funid args) b = f funid args b

1
src/runtime/haskell/PGF/Haskell.hs
View File

@@ -33,6 +33,7 @@ fromStr = from False id
from space cap ts =
case ts of
[] -> []
TK "":ts -> from space cap ts
TK s:ts -> put s++from True cap ts
BIND:ts -> from False cap ts
SOFT_BIND:ts -> from False cap ts

24
src/runtime/haskell/PGF/Macros.hs
View File

@@ -137,7 +137,7 @@ cidVar = mkCId "__gfVar"
-- mark the beginning and the end of each constituent.
data BracketedString
= Leaf Token -- ^ this is the leaf i.e. a single token
| Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedString]
| Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedString]
-- ^ this is a bracket. The 'CId' is the category of
-- the phrase. The 'FId' is an unique identifier for
-- every phrase in the sentence. For context-free grammars
@@ -151,7 +151,7 @@ data BracketedString
-- that represents the same constituent.
data BracketedTokn
= Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn] -- Invariant: the list is not empty
= Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [Expr] [BracketedTokn] -- Invariant: the list is not empty
| LeafKS Token
| LeafNE
| LeafBIND
@@ -169,12 +169,12 @@ showBracketedString :: BracketedString -> String
showBracketedString = render . ppBracketedString
ppBracketedString (Leaf t) = text t
ppBracketedString (Bracket cat fid index _ _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
ppBracketedString (Bracket cat fid fid' index _ _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
-- | The length of the bracketed string in number of tokens.
lengthBracketedString :: BracketedString -> Int
lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
untokn :: Maybe String -> [BracketedTokn] -> (Maybe String,[BracketedString])
untokn nw bss =
@@ -183,10 +183,10 @@ untokn nw bss =
Just bss -> (nw,concat bss)
Nothing -> (nw,[])
where
untokn nw (Bracket_ cat fid index fun es bss) =
untokn nw (Bracket_ cat fid fid' index fun es bss) =
let (nw',bss') = mapAccumR untokn nw bss
in case sequence bss' of
Just bss -> (nw',Just [Bracket cat fid index fun es (concat bss)])
Just bss -> (nw',Just [Bracket cat fid fid' index fun es (concat bss)])
Nothing -> (Nothing, Nothing)
untokn nw (LeafKS t)
| null t = (nw,Just [])
@@ -227,16 +227,16 @@ computeSeq filter seq args = concatMap compute seq
getArg d r
| not (null arg_lin) &&
filter ct = [Bracket_ cat fid r fun es arg_lin]
filter ct = [Bracket_ cat fid fid' r fun es arg_lin]
| otherwise = arg_lin
where
arg_lin = lin ! r
(ct@(cat,fid),_,fun,es,(_xs,lin)) = args !! d
arg_lin = lin ! r
(ct@(cat,fid),fid',fun,es,(_xs,lin)) = args !! d
getVar d r = [LeafKS (showCId (xs !! r))]
where
(_ct,_,_fun,_es,(xs,_lin)) = args !! d
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ _ bss) = concatMap flattenBracketedString bss
flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ _ _ bss) = concatMap flattenBracketedString bss

6
src/runtime/haskell/PGF/Parse.hs
View File

@@ -198,7 +198,7 @@ recoveryStates open_types (EState abs cnc chart) =
Nothing -> []
complete open_fcats items ac =
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
foldl (Set.foldr (\(Active j' ppos funid seqid args keyc) ->
(:) (Active j' (ppos+1) funid seqid args keyc)))
items
[set | fcat <- open_fcats, (set,_) <- lookupACByFCat fcat ac]
@@ -363,7 +363,7 @@ process flit ftok cnc (item@(Active j ppos funid seqid args key0):items) acc cha
items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of
Nothing -> items
Just (set,sc) -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
Just (set,sc) -> Set.foldr (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt (sequences cnc) seqid) ppos
PArg hypos _ = args !! d
in (:) (Active j' (ppos+1) funid seqid (updateAt d (PArg hypos fid) args) keyc)) items set
@@ -395,7 +395,7 @@ process flit ftok cnc (item@(Active j ppos funid seqid args key0):items) acc cha
predict flit ftok cnc forest key0 key@(AK fid lbl) k acc items =
let (acc1,items1) = case IntMap.lookup fid forest of
Nothing -> (acc,items)
Just set -> Set.fold foldProd (acc,items) set
Just set -> Set.foldr foldProd (acc,items) set
(acc2,items2) = case IntMap.lookup fid (lexicon cnc) >>= IntMap.lookup lbl of
Just tmap -> let (mb_v,toks) = TrieMap.decompose (TrieMap.map (toItems key0 k) tmap)

4
src/runtime/haskell/PGF/TrieMap.hs
View File

@@ -79,12 +79,12 @@ unionsWith f = foldl (unionWith f) empty
elems :: TrieMap k v -> [v]
elems tr = collect tr []
where
collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.fold collect xs m)
collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.foldr collect xs m)
toList :: TrieMap k v -> [([k],v)]
toList tr = collect [] tr []
where
collect ks (Tr mb_v m) xs = maybe id (\v -> (:) (ks,v)) mb_v (Map.foldWithKey (\k -> collect (k:ks)) xs m)
collect ks (Tr mb_v m) xs = maybe id (\v -> (:) (ks,v)) mb_v (Map.foldrWithKey (\k -> collect (k:ks)) xs m)
fromListWith :: Ord k => (v -> v -> v) -> [([k],v)] -> TrieMap k v
fromListWith f xs = foldl' (\trie (ks,v) -> insertWith f ks v trie) empty xs

128
src/runtime/haskell/PGF/VisualizeTree.hs
View File

@@ -34,8 +34,9 @@ import PGF.Macros (lookValCat, BracketedString(..))
import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
import Data.List (intersperse,nub,mapAccumL,find,groupBy)
--import Data.Char (isDigit)
import Data.List (intersperse,nub,mapAccumL,find,groupBy,sortBy,partition)
import Data.Ord (comparing)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Text.PrettyPrint
@@ -131,6 +132,7 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
"latex" -> render . ppLaTeX $ conll2latex' conll
"svg" -> render . ppSVG . toSVG $ conll2latex' conll
"conll" -> printCoNLL conll
"conllu" -> printCoNLL ([["# text = " ++ linearize pgf lang t], ["# tree = " ++ showExpr [] t]] ++ conll)
"malt_tab" -> render $ vcat (map (hcat . intersperse (char '\t') . (\ws -> [ws !! 0,ws !! 1,ws !! 3,ws !! 6,ws !! 7])) wnodes)
"malt_input" -> render $ vcat (map (hcat . intersperse (char '\t') . take 6) wnodes)
_ -> render $ text "digraph {" $$
@@ -144,16 +146,16 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
conll = maybe conll0 (\ls -> fixCoNLL ls conll0) mclab
conll0 = (map.map) render wnodes
nodes = map mkNode leaves
links = map mkLink [(fid, fromMaybe (dep_lbl,nil) (lookup fid deps)) | ((cat,fid,fun),_,w) <- tail leaves]
links = map mkLink [(fid, fromMaybe (dep_lbl,nil) (lookup fid deps)) | ((cat,fid,fun,_),_,w) <- tail leaves]
-- CoNLL format: ID FORM LEMMA PLEMMA POS PPOS FEAT PFEAT HEAD PHEAD DEPREL PDEPREL
-- P variants are automatically predicted rather than gold standard
wnodes = [[int i, maltws ws, ppCId fun, ppCId (posCat cat), ppCId cat, unspec, int parent, text lab, unspec, unspec] |
((cat,fid,fun),i,ws) <- tail leaves,
wnodes = [[int i, maltws ws, ppCId fun, ppCId (posCat cat), ppCId cat, int lind, int parent, text lab, unspec, unspec] |
((cat,fid,fun,lind),i,ws) <- tail leaves,
let (lab,parent) = fromMaybe (dep_lbl,0)
(do (lbl,fid) <- lookup fid deps
(_,i,_) <- find (\((_,fid1,_),i,_) -> fid == fid1) leaves
(_,i,_) <- find (\((_,fid1,_,_),i,_) -> fid == fid1) leaves
return (lbl,i))
]
maltws = text . concat . intersperse "+" . words -- no spaces in column 2
@@ -162,7 +164,7 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
bss = bracketedLinearize pgf lang t
root = (wildCId,nil,wildCId)
root = (wildCId,nil,wildCId,0)
leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . concatMap (getLeaves root)) bss
deps = let (_,(h,deps)) = getDeps 0 [] t []
@@ -180,10 +182,10 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
getLeaves parent bs =
case bs of
Leaf w -> [(parent,w)]
Bracket cat fid _ fun _ bss -> concatMap (getLeaves (cat,fid,fun)) bss
Leaf w -> [(parent,w)]
Bracket cat fid _ lind fun _ bss -> concatMap (getLeaves (cat,fid,fun,lind)) bss
mkNode ((_,p,_),i,w) =
mkNode ((_,p,_,_),i,w) =
tag p <+> brackets (text "label = " <> doubleQuotes (int i <> char '.' <+> text w)) <+> semi
mkLink (x,(lbl,y)) = tag y <+> text "->" <+> tag x <+> text "[label = " <> doubleQuotes (text lbl) <> text "] ;"
@@ -234,10 +236,18 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
root_lbl = "ROOT"
unspec = text "_"
-- auxiliaries for UD conversion PK 15/12/2018
rmcomments :: String -> String
rmcomments [] = []
rmcomments ('-':'-':xs) = []
rmcomments ('-':x :xs) = '-':rmcomments (x:xs)
rmcomments (x:xs) = x:rmcomments xs
-- | Prepare lines obtained from a configuration file for labels for
-- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@.
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
-- getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s)]
-- the old function, without dependencies
graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
@@ -291,13 +301,13 @@ graphvizBracketedString opts mbl tree bss = render graphviz_code
getInternals [] = []
getInternals nodes
= nub [(parent, fid, mkNode fun cat) |
(parent, Bracket cat fid _ fun _ _) <- nodes]
(parent, Bracket cat fid _ _ fun _ _) <- nodes]
: getInternals [(fid, child) |
(_, Bracket _ fid _ _ _ children) <- nodes,
(_, Bracket _ fid _ _ _ _ children) <- nodes,
child <- children]
getLeaves cat parent (Leaf word) = [(parent, (cat, word))] -- the lowest cat before the word
getLeaves _ parent (Bracket cat fid i _ _ children)
getLeaves _ parent (Bracket cat fid _ i _ _ children)
= concatMap (getLeaves cat fid) children
mkLevel nodes
@@ -401,8 +411,8 @@ genPreAlignment pgf langs = lin2align . linsBracketed
getLeaves parent bs =
case bs of
Leaf w -> [(parent,w)]
Bracket _ fid _ _ _ bss -> concatMap (getLeaves fid) bss
Leaf w -> [(parent,w)]
Bracket _ fid _ _ _ _ bss -> concatMap (getLeaves fid) bss
mkLayers (cs:css:rest) = let (lrest, rrest) = mkLayers (css:rest)
in ((fields cs) : lrest, (map (mkLinks css) cs) : rrest)
@@ -512,7 +522,7 @@ 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..)
, tokens :: [(String,(String,String))] -- word, (pos,features) (0..)
, deps :: [((Int,Int),String)] -- from, to, label
, root :: Int -- root word position
}
@@ -552,7 +562,8 @@ 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
++ [Put (wpos rwld i,15) (TinyText w) | (i,(w,_)) <- zip [0..] (map snd (tokens d))] -- pos tags 15u above bottom
--- ++ [Put (wpos rwld i,-15) (TinyText w) | (i,(_,w)) <- zip [0..] (map snd (tokens d))] -- features 15u below bottom -> DON'T SHOW
++ 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")]
@@ -583,8 +594,8 @@ conll2dep' ls = Dep {
, 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]
wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,(pos,feat)) = toks !! i in [tok,pos {-,feat-}]]) --- feat not shown
toks = [(w,(c,m)) | _:w:_:c:_:m:_ <- ls]
dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"]
--maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]
@@ -749,18 +760,26 @@ ppSVG svg =
-- 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
type CncLabels = [
Either
(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
(String,[String])
-- (category, morphological forms)
]
fixCoNLL :: CncLabels -> CoNLL -> CoNLL
fixCoNLL labels conll = map fixc conll where
fixCoNLL cncLabels conll = map fixc conll where
labels = [l | Left l <- cncLabels]
flabels = [r | Right r <- cncLabels]
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_:"0":"dep":xs) -> (i:word:fun:pos:cat:(feat cat word 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
Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:(feat cat word x_):j :label':xs)
Just (pos',label',target) -> (i:word:fun:pos' pos:cat:(feat cat word x_): getDep j target:label':xs)
_ -> (i:word:fun:pos:cat:(feat cat word x_):j:label:xs)
_ -> row
look (fun,word) = case lookup fun labels of
@@ -775,16 +794,48 @@ fixCoNLL labels conll = map fixc conll where
getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll]
feat cat word x = case lookup cat flabels of
Just tags | all isDigit x && length tags > read x -> tags !! read x
_ -> case lookup (show word) flabels of
Just (t:_) -> t
_ -> cat ++ "-" ++ x
getCncDepLabels :: String -> CncLabels
getCncDepLabels = map merge . groupBy (\ (x,_) (a,_) -> x == a) . concatMap analyse . filter choose . lines where
getCncDepLabels s = wlabels ws ++ flabels fs
where
wlabels =
map Left .
map merge .
groupBy (\ (x,_) (a,_) -> x == a) .
sortBy (comparing fst) .
concatMap analyse .
filter chooseW
flabels =
map Right .
map collectTags .
map words
(fs,ws) = partition chooseF $ map uncomment $ lines s
--- choose is for compatibility with the general notation
choose line = notElem '(' line && elem '{' line --- ignoring non-local (with "(") and abstract (without "{") rules
chooseW line = notElem '(' line &&
elem '{' line
--- ignoring non-local (with "(") and abstract (without "{") rules
---- TODO: this means that "(" cannot be a token
chooseF line = take 1 line == "@" --- feature assignments have the form e.g. @N SgNom SgGen ; no spaces inside tags
uncomment line = case line of
'-':'-':_ -> ""
c:cs -> c : uncomment cs
_ -> line
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]
(toks,_:target) -> case (getToks beg, words target) of
(funs,[ label,j]) -> [(fun, (tok, (id, label,j))) | fun <- funs, tok <- getToks toks]
(funs,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | fun <- funs, tok <- getToks toks]
_ -> []
_ -> []
_ -> []
@@ -793,8 +844,13 @@ getCncDepLabels = map merge . groupBy (\ (x,_) (a,_) -> x == a) . concatMap ana
Just new -> return new
_ -> lookup "*" (map snd rules)
)
getToks = words . map (\c -> if elem c "\"," then ' ' else c)
getToks = map unquote . filter (/=",") . toks
toks s = case lex s of [(t,"")] -> [t] ; [(t,cc)] -> t:toks cc ; _ -> []
unquote s = case s of '"':cc@(_:_) | last cc == '"' -> init cc ; _ -> s
collectTags (w:ws) = (tail w,ws)
-- added init to remove the last \n. otherwise, two empty lines are in between each sentence PK 17/12/2018
printCoNLL :: CoNLL -> String
printCoNLL = unlines . map (concat . intersperse "\t")
printCoNLL = init . unlines . map (concat . intersperse "\t")

27
src/runtime/haskell/pgf.cabal
View File

@@ -1,5 +1,5 @@
name: pgf
version: 3.9-git
version: 3.10
cabal-version: >= 1.20
build-type: Simple
@@ -12,11 +12,6 @@ bug-reports: https://github.com/GrammaticalFramework/GF/issues
maintainer: Thomas Hallgren
tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
flag custom-binary
Description: Use a customised version of the binary package
Default: True
Manual: True
Library
default-language: Haskell2010
build-depends: base >= 4.6 && <5,
@@ -29,18 +24,14 @@ Library
mtl,
exceptions
if flag(custom-binary)
hs-source-dirs: ., binary
other-modules:
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
else
build-depends: binary, data-binary-ieee754
other-modules:
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
--ghc-options: -fwarn-unused-imports
--if impl(ghc>=7.8)

32
src/runtime/java/Makefile
View File

@@ -1,29 +1,37 @@
INSTALL_PATH = /usr/local
C_SOURCES = jpgf.c jsg.c jni_utils.c
JAVA_SOURCES = $(wildcard org/grammaticalframework/pgf/*.java) \
$(wildcard org/grammaticalframework/sg/*.java)
JNI_INCLUDES = $(if $(wildcard /usr/lib/jvm/default-java/include/.*), -I/usr/lib/jvm/default-java/include -I/usr/lib/jvm/default-java/include/linux, \
$(if $(wildcard /System/Library/Frameworks/JavaVM.framework/Versions/A/Headers/.*), -I/System/Library/Frameworks/JavaVM.framework/Versions/A/Headers, \
$(if $(wildcard /Library/Java/Home/include/.*), -I/Library/Java/Home/include/ -I/Library/Java/Home/include/darwin, \
$(error No JNI headers found))))
$(if $(wildcard /usr/lib/jvm/java-1.11.0-openjdk-amd64/include/.*), -I/usr/lib/jvm/java-1.11.0-openjdk-amd64/include/ -I/usr/lib/jvm/java-1.11.0-openjdk-amd64/include/linux, \
$(if $(wildcard /System/Library/Frameworks/JavaVM.framework/Versions/A/Headers/.*), -I/System/Library/Frameworks/JavaVM.framework/Versions/A/Headers, \
$(if $(wildcard /Library/Java/Home/include/.*), -I/Library/Java/Home/include/ -I/Library/Java/Home/include/darwin, \
$(error No JNI headers found)))))
# For Windows replace the previous line with something like this:
# For compilation on Windows replace the previous line with something like this:
#
# JNI_INCLUDES = -I "C:/Program Files/Java/jdk1.8.0_171/include" -I "C:/Program Files/Java/jdk1.8.0_171/include/win32" -I "C:/MinGW/msys/1.0/local/include"
# WINDOWS_FLAGS = -L"C:/MinGW/msys/1.0/local/lib" -no-undefined
# WINDOWS_LDFLAGS = -L"C:/MinGW/msys/1.0/local/lib" -no-undefined
INSTALL_PATH = /usr/local/lib
LIBTOOL = glibtool --tag=CC
GCC = gcc
LIBTOOL = $(if $(shell command -v glibtool 2>/dev/null), glibtool, libtool) --tag=CC
LIBTOOL = $(if $(shell command -v glibtool 2>/dev/null), glibtool --tag=CC, libtool)
# For cross-compilation from Linux to Windows replace the previous two lines with:
#
# GCC = x86_64-w64-mingw32-gcc
# LIBTOOL = ../c/libtool
# WINDOWS_CCFLAGS = -I$(INSTALL_PATH)/include
# WINDOWS_LDFLAGS = -L$(INSTALL_PATH)/lib -no-undefined
all: libjpgf.la jpgf.jar
libjpgf.la: $(patsubst %.c, %.lo, $(C_SOURCES))
$(LIBTOOL) --mode=link gcc $(CFLAGS) -g -O -o libjpgf.la -shared $^ -rpath $(INSTALL_PATH) -lgu -lpgf -lsg $(WINDOWS_FLAGS)
$(LIBTOOL) --mode=link $(GCC) $(CFLAGS) -g -O -o libjpgf.la -shared $^ -rpath $(INSTALL_PATH)/lib -lgu -lpgf -lsg $(WINDOWS_LDFLAGS)
%.lo : %.c
$(LIBTOOL) --mode=compile gcc $(CFLAGS) -g -O -c $(JNI_INCLUDES) -std=c99 -shared $< -o $@
$(LIBTOOL) --mode=compile $(GCC) $(CFLAGS) -g -O -c $(JNI_INCLUDES) $(WINDOWS_CCFLAGS) -std=c99 -shared $< -o $@
jpgf.jar: $(patsubst %.java, %.class, $(JAVA_SOURCES))
jar -cf $@ org/grammaticalframework/pgf/*.class org/grammaticalframework/sg/*.class
@@ -32,8 +40,8 @@ jpgf.jar: $(patsubst %.java, %.class, $(JAVA_SOURCES))
javac $<
install: libjpgf.la jpgf.jar
$(LIBTOOL) --mode=install install -s libjpgf.la $(INSTALL_PATH)
install jpgf.jar $(INSTALL_PATH)
$(LIBTOOL) --mode=install install -s libjpgf.la $(INSTALL_PATH)/lib
install jpgf.jar $(INSTALL_PATH)/lib
doc:

4
src/runtime/javascript/DEPRECATED.md Normal file
View File

@@ -0,0 +1,4 @@
# Deprecation notice
As of June 2019, this JavaScript version of the GF runtime is considered deprecated,
in favour of the TypeScript version in <https://github.com/GrammaticalFramework/gf-typescript>.

796
src/runtime/javascript/gflib.js
View File

File diff suppressed because it is too large Load Diff

2
src/runtime/javascript/grammar.js
View File

File diff suppressed because one or more lines are too long

2
src/runtime/javascript/translator.html
View File

@@ -32,7 +32,7 @@
</script>
<title>Web-based GF Translator</title>
</head>
<body onload="populateLangs(Food, 'fromLang', 'toLang')">
<body onload="populateLangs(grammar, 'fromLang', 'toLang')">
<form id="translate">
<p>
<input type="text" name="inputText" id="inputText" value="this cheese is warm" size="50" />

7
src/runtime/typescript/MOVED.md Normal file
View File

@@ -0,0 +1,7 @@
# Project moved
The GF TypeScript runtime has been moved to the repository:
<https://github.com/GrammaticalFramework/gf-typescript>
If you are looking for an updated version of the JavaScript runtime,
you should also look there.

337
src/runtime/typescript/gflib.d.ts vendored
View File

@@ -1,337 +0,0 @@
/**
* gflib.dt.s
*
* by John J. Camilleri
*
* TypeScript type definitions for the "original" JS GF runtime (GF:src/runtime/javascript/gflib.js)
*/
// Note: the String prototype is extended with:
// String.prototype.tag = "";
// String.prototype.setTag = function (tag) { this.tag = tag; };
/**
* A GF grammar is one abstract and multiple concretes
*/
declare class GFGrammar {
abstract: GFAbstract
concretes: {[key: string]: GFConcrete}
constructor(abstract: GFAbstract, concretes: {[key: string]: GFConcrete})
translate(
input: string,
fromLang: string,
toLang: string
): {[key: string]: {[key: string]: string}}
}
/**
* Abstract Syntax Tree
*/
declare class Fun {
name: string
args: Fun[]
constructor(name: string, ...args: Fun[])
print(): string
show(): string
getArg(i: number): Fun
setArg(i: number, c: Fun): void
isMeta(): boolean
isComplete(): boolean
isLiteral(): boolean
isString(): boolean
isInt(): boolean
isFloat(): boolean
isEqual(obj: any): boolean
}
/**
* Abstract syntax
*/
declare class GFAbstract {
startcat: string
types: {[key: string]: Type} // key is function name
constructor(startcat: string, types: {[key: string]: Type})
addType(fun: string, args: string[], cat: string): void
getArgs(fun: string): string[]
getCat(fun: string): string
annotate(tree: Fun, type: string): Fun
handleLiterals(tree: Fun, type: Type): Fun
copyTree(x: Fun): Fun
parseTree(str: string, type: string): Fun
parseTree_(tokens: string[], prec: number): Fun
}
/**
* Type
*/
declare class Type {
args: string[]
cat: string
constructor(args: string[], cat: string)
}
type ApplyOrCoerce = Apply | Coerce
/**
* Concrete syntax
*/
declare class GFConcrete {
flags: {[key: string]: string}
productions: {[key: number]: ApplyOrCoerce[]}
functions: CncFun[]
sequences: Array<Array<Sym>>
startCats: {[key: string]: {s: number, e: number}}
totalFIds: number
pproductions: {[key: number]: ApplyOrCoerce[]}
lproductions: {[key: string]: {fid: FId, fun: CncFun}}
constructor(
flags: {[key: string]: string},
productions: {[key: number]: ApplyOrCoerce[]},
functions: CncFun[],
sequences: Array<Array<Sym>>,
startCats: {[key: string]: {s: number, e: number}},
totalFIds: number
)
linearizeSyms(tree: Fun, tag: string): Array<{fid: FId, table: any}>
syms2toks(syms: Sym[]): string[]
linearizeAll(tree: Fun): string[]
linearize(tree: Fun): string
tagAndLinearize(tree: Fun): string[]
unlex(ts: string): string
tagIt(obj: any, tag: string): any
// showRules(): string // Uncaught TypeError: Cannot read property 'length' of undefined at gflib.js:451
tokenize(string: string): string[]
parseString(string: string, cat: string): Fun[]
complete(
input: string,
cat: string
): {consumed: string[], suggestions: string[]}
}
/**
* Function ID
*/
type FId = number
/**
* Apply
*/
declare class Apply {
id: string
fun: FId
args: PArg[]
constructor(fun: FId, args: PArg[])
show(cat: string): string
isEqual(obj: any): boolean
}
/**
* PArg
*/
declare class PArg {
fid: FId
hypos: any[]
constructor(fid: FId, ...hypos: any[])
}
/**
* Coerce
*/
declare class Coerce {
id: string
arg: FId
constructor(arg: FId)
show(cat: string): string
}
/**
* Const
*/
declare class Const {
id: string
lit: Fun
toks: any[]
constructor(lit: Fun, toks: any[])
show(cat: string): string
isEqual(obj: any): boolean
}
/**
* CncFun
*/
declare class CncFun {
name: string
lins: FId[]
constructor(name: string, lins: FId[])
}
type Sym = SymCat | SymKS | SymKP | SymLit
/**
* SymCat
*/
declare class SymCat {
id: string
i: number
label: number
constructor(i: number, label: number)
getId(): string
getArgNum(): number
show(): string
}
/**
* SymKS
*/
declare class SymKS {
id: string
tokens: string[]
constructor(...tokens: string[])
getId(): string
show(): string
}
/**
* SymKP
*/
declare class SymKP {
id: string
tokens: string[]
alts: Alt[]
constructor(tokens: string[], alts: Alt[])
getId(): string
show(): string
}
/**
* Alt
*/
declare class Alt {
tokens: string[]
prefixes: string[]
constructor(tokens: string[], prefixes: string[])
}
/**
* SymLit
*/
declare class SymLit {
id: string
i: number
label: number
constructor(i: number, label: number)
getId(): string
show(): string
}
/**
* Trie
*/
declare class Trie {
value: any
items: Trie[]
insertChain(keys, obj): void
insertChain1(keys, obj): void
lookup(key, obj): any
isEmpty(): boolean
}
/**
* ParseState
*/
declare class ParseState {
concrete: GFConcrete
startCat: string
items: Trie
chart: Chart
constructor(concrete: GFConcrete, startCat: string)
next(token: string): boolean
complete(correntToken: string): Trie
extractTrees(): any[]
process(
agenda,
literalCallback: (fid: FId) => any,
tokenCallback: (tokens: string[], item: any) => any
): void
}
/**
* Chart
*/
declare class Chart {
active: any
actives: {[key: number]: any}
passive: any
forest: {[key: number]: ApplyOrCoerce[]}
nextId: number
offset: number
constructor(concrete: GFConcrete)
lookupAC(fid: FId,label)
lookupACo(offset, fid: FId, label)
labelsAC(fid: FId)
insertAC(fid: FId, label, items): void
lookupPC(fid: FId, label, offset)
insertPC(fid1: FId, label, offset, fid2: FId): void
shift(): void
expandForest(fid: FId): any[]
}
/**
* ActiveItem
*/
declare class ActiveItem {
offset: number
dot: number
fun: CncFun
seq: Array<Sym>
args: PArg[]
fid: FId
lbl: number
constructor(
offset: number,
dot: number,
fun: CncFun,
seq: Array<Sym>,
args: PArg[],
fid: FId,
lbl: number
)
isEqual(obj: any): boolean
shiftOverArg(i: number, fid: FId): ActiveItem
shiftOverTokn(): ActiveItem
}

4
src/server/Cache.hs
View File

@@ -9,7 +9,7 @@ import Data.Maybe(mapMaybe)
import System.Directory (getModificationTime)
import System.Mem(performGC)
import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
import Data.Time.Compat (toUTCTime)
--import Data.Time.Compat (toUTCTime)
data Cache a = Cache {
cacheLoad :: FilePath -> IO a,
@@ -63,7 +63,7 @@ readCache' c file =
Nothing -> do v <- newMVar Nothing
return (Map.insert file v objs, v)
-- Check time stamp, and reload if different than the cache entry
readObject m = do t' <- toUTCTime `fmap` getModificationTime file
readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
now <- getCurrentTime
x' <- case m of
Just (t,_,x) | t' == t -> return x

110
src/server/FastCGIUtils.hs
View File

@@ -1,110 +0,0 @@
{-# LANGUAGE CPP #-}
module FastCGIUtils(initFastCGI,loopFastCGI) where
import Control.Concurrent(ThreadId,myThreadId)
import Control.Exception(ErrorCall(..),throw,throwTo,catch)
import Control.Monad(when,liftM,liftM2)
import Data.IORef(IORef,newIORef,readIORef,writeIORef)
import Prelude hiding (catch)
import System.Environment(getArgs,getProgName)
import System.Exit(ExitCode(..),exitWith)
import System.IO(hPutStrLn,stderr)
import System.IO.Unsafe(unsafePerformIO)
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import Network.FastCGI
import CGIUtils(logError)
-- There are used in MorphoService.hs, but not in PGFService.hs
initFastCGI :: IO ()
initFastCGI = installSignalHandlers
loopFastCGI :: CGI CGIResult -> IO ()
loopFastCGI f =
do (do runOneFastCGI f
exitIfToldTo
restartIfModified)
`catchAborted` logError "Request aborted"
loopFastCGI f
-- Signal handling for FastCGI programs.
#ifndef mingw32_HOST_OS
installSignalHandlers :: IO ()
installSignalHandlers =
do t <- myThreadId
installHandler sigUSR1 (Catch gracefulExit) Nothing
installHandler sigTERM (Catch gracelessExit) Nothing
installHandler sigPIPE (Catch (requestAborted t)) Nothing
return ()
requestAborted :: ThreadId -> IO ()
requestAborted t = throwTo t (ErrorCall "**aborted**")
gracelessExit :: IO ()
gracelessExit = do logError "Graceless exit"
exitWith ExitSuccess
gracefulExit :: IO ()
gracefulExit =
do logError "Graceful exit"
writeIORef shouldExit True
#else
installSignalHandlers :: IO ()
installSignalHandlers = return ()
#endif
exitIfToldTo :: IO ()
exitIfToldTo =
do b <- readIORef shouldExit
when b $ do logError "Exiting..."
exitWith ExitSuccess
{-# NOINLINE shouldExit #-}
shouldExit :: IORef Bool
shouldExit = unsafePerformIO $ newIORef False
catchAborted :: IO a -> IO a -> IO a
catchAborted x y = x `catch` \e -> case e of
ErrorCall "**aborted**" -> y
_ -> throw e
-- Restart handling for FastCGI programs.
#ifndef mingw32_HOST_OS
{-# NOINLINE myModTimeRef #-}
myModTimeRef :: IORef EpochTime
myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
-- FIXME: doesn't get directory
myProgPath :: IO FilePath
myProgPath = getProgName
getProgModTime :: IO EpochTime
getProgModTime = liftM modificationTime (myProgPath >>= getFileStatus)
needsRestart :: IO Bool
needsRestart = liftM2 (/=) (readIORef myModTimeRef) getProgModTime
exitIfModified :: IO ()
exitIfModified =
do restart <- needsRestart
when restart $ exitWith ExitSuccess
restartIfModified :: IO ()
restartIfModified =
do restart <- needsRestart
when restart $ do prog <- myProgPath
args <- getArgs
hPutStrLn stderr $ prog ++ " has been modified, restarting ..."
-- FIXME: setCurrentDirectory?
executeFile prog False args Nothing
#else
restartIfModified :: IO ()
restartIfModified = return ()
#endif

128
src/server/PGFService.hs
View File

@@ -3,10 +3,8 @@ module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF (PGF,Labels,CncLabels)
import PGF2
import GF.Text.Lexing
import qualified PGF
import Cache
import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
outputBinary,outputBinary',
@@ -62,8 +60,8 @@ data Caches = Caches { qsem :: QSem,
newPGFCache jobs = do let n = maybe 4 id jobs
qsem <- newQSem n
pgfCache <- newCache' PGF.readPGF
lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
pgfCache <- newCache' readPGF
lblCache <- newCache' (fmap getDepLabels . readFile)
return $ Caches qsem pgfCache lblCache
flushPGFCache c = do flushCache (pgfCache c)
flushCache (labelsCache c)
@@ -108,6 +106,8 @@ pgfMain qsem command (t,pgf) =
"parse" -> withQSem qsem $
out t=<< join (parse # input % start % limit % treeopts)
"linearize" -> out t=<< lin # tree % to
"bracketedLinearize"
-> out t=<< bracketedLin # tree % to
"linearizeAll"-> out t=<< linAll # tree % to
"translate" -> withQSem qsem $
out t=<<join(trans # input % to % start % limit%treeopts)
@@ -142,7 +142,9 @@ pgfMain qsem command (t,pgf) =
where
bad err = ["parseFailed".=err]
good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
tp (tree,prob) = makeObj ["tree".=tree
,"prob".=prob
]
parse' start mlimit ((from,concr),input) =
case parseWithHeuristics concr cat input (-1) callbacks of
@@ -162,6 +164,10 @@ pgfMain qsem command (t,pgf) =
lin' tree (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos]
bracketedLin tree to = showJSON (bracketedLin' tree to)
bracketedLin' tree (tos,unlex) =
[makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
trans input@((from,_),_) to start mlimit (trie,jsontree) =
do parses <- parse' start mlimit input
return $
@@ -171,9 +177,9 @@ pgfMain qsem command (t,pgf) =
jsonParses = either bad good
where
bad err = [makeObj ["error".=err]]
good parses = [makeObj (addTree jsontree tree++
["prob".=prob,
"linearizations".=lin' tree to])
good parses = [makeObj ["tree".=tree
,"prob".=prob
,"linearizations".=lin' tree to]
| (tree,prob) <- parses]
morpho (from,concr) input =
@@ -465,8 +471,8 @@ doLookupMorpho pgf from input =
ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input
-}
type From = (Maybe PGF.Language,String)
type To = ([PGF.Language],Unlexer)
type From = (Maybe Concr,String)
type To = ([Concr],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
{-
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
@@ -560,10 +566,7 @@ doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj
addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
-}
addTree json tree = "tree".=showTree tree:
["jsontree".= jsonExpr tree | json]
{-
doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
doComplete pgf (mfrom,input) mcat mlimit full = showJSON
[makeObj (
@@ -849,107 +852,34 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
-}
class ToATree a where
showTree :: a -> String
toATree :: a -> PGF.ATree a
instance ToATree PGF.Expr where
showTree = PGF.showExpr []
toATree = PGF.toATree
instance JSON Expr where
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr
showJSON = showJSON . showExpr []
-- | Render trees as JSON with numbered functions
jsonExpr e = evalState (expr (toATree e)) 0
where
expr e =
case e of
PGF.Other e -> return (makeObj ["other".=e])
PGF.App f es ->
do js <- mapM expr es
let children=["children".=js | not (null js)]
i<-inc
return $ makeObj (["fun".=f,"fid".=i]++children)
inc :: State Int Int
inc = do i <- get; put (i+1); return i
instance JSON PGF.Trie where
showJSON (PGF.Oth e) = makeObj ["other".=e]
showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
-- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
instance JSON PGF.CId where
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
showJSON = showJSON . PGF.showLanguage
instance JSON PGF.Expr where
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . PGF.readExpr
showJSON = showJSON . PGF.showExpr []
instance JSON PGF.BracketedString where
readJSON x = return (PGF.Leaf "")
showJSON (PGF.Bracket cat fid index fun bs) =
instance JSON BracketedString where
readJSON x = return (Leaf "")
showJSON (Bracket cat fid index fun bs) =
makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
showJSON (PGF.Leaf s) = makeObj ["token".=s]
showJSON (Leaf s) = makeObj ["token".=s]
-- * PGF utilities
{-
cat :: PGF -> Maybe PGF.Type -> PGF.Type
cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
-}
parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,PGF.ParseOutput,PGF.BracketedString)]
parse' pgf input mcat mfrom =
[(from,po,bs) | from <- froms, (po,bs) <- [PGF.parse_ pgf from cat Nothing input]]
where froms = maybe (PGF.languages pgf) (:[]) mfrom
cat = fromMaybe (PGF.startCat pgf) mcat
complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String
-> (PGF.BracketedString, String, Map.Map PGF.Token [PGF.CId])
complete' pgf from typ mlimit input =
let (ws,prefix) = tokensAndPrefix input
in PGF.complete pgf from typ (unwords ws) prefix
where
tokensAndPrefix :: String -> ([String],String)
tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "")
| null ws = ([],"")
| otherwise = (init ws, last ws)
where ws = words s
transfer lang = if "LaTeX" `isSuffixOf` show lang
then fold -- OpenMath LaTeX transfer
else id
-- | tabulate all variants and their forms
linearizeTabular
:: PGF -> To -> PGF.Tree -> [(PGF.Language,[(String,[String])])]
linearizeTabular pgf (tos,unlex) tree =
[(to,lintab to (transfer to tree)) | to <- langs]
where
langs = if null tos then PGF.languages pgf else tos
lintab to t = [(p,map unlex (nub [t|(p',t)<-vs,p'==p]))|p<-ps]
where
ps = nub (map fst vs)
vs = concat (PGF.tabularLinearizes pgf to t)
linearizeAndUnlex pgf (mto,unlex) tree =
[(to,s,bss) | to<-langs,
let bss = PGF.bracketedLinearize pgf to (transfer to tree)
s = unlex . unwords $ concatMap PGF.flattenBracketedString bss]
where
langs = if null mto then PGF.languages pgf else mto
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
selectLanguage pgf macc = case acceptable of
[] -> case PGF.languages pgf of
[] -> case Map.elems (languages pgf) of
[] -> error "No concrete syntaxes in PGF grammar."
l:_ -> l
Language c:_ -> fromJust (langCodeLanguage pgf c)
where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf)
where langCodes = mapMaybe languageCode (Map.elems (languages pgf))
acceptable = negotiate (map Language langCodes) macc
langCodeLanguage :: PGF -> String -> Maybe PGF.Language
langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code]
langCodeLanguage :: PGF -> String -> Maybe Concr
langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
-- * General utilities

357
src/server/exec/ContentService.hs
View File

@@ -1,357 +0,0 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-}
import PGF (PGF)
import qualified PGF
import Cache
import FastCGIUtils
import URLEncoding
import Data.Maybe
import Network.FastCGI
import Text.JSON
import qualified Data.ByteString.Lazy as BS
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString)
import Control.Monad
import Control.Exception
import Control.Concurrent(forkIO)
import System.Environment(getArgs)
import System.Time
import System.Locale
import System.FilePath
import Database.HSQL.MySQL
import Database.HSQL.Types(toSqlValue)
logFile :: FilePath
logFile = "content-error.log"
main :: IO ()
main = do
args <- getArgs
case args of
[] -> do stderrToFile logFile
cache <- newCache dbConnect
#ifndef mingw32_HOST_OS
runFastCGIConcurrent' forkIO 100 (cgiMain cache)
#else
runFastCGI (cgiMain cache)
#endif
[fpath] -> do c <- dbConnect fpath
dbInit c
getPath = getVarWithDefault "SCRIPT_FILENAME" ""
cgiMain :: Cache Connection -> CGI CGIResult
cgiMain cache = handleErrors . handleCGIErrors $
cgiMain' cache =<< getPath
cgiMain' :: Cache Connection -> FilePath -> CGI CGIResult
cgiMain' cache path =
do c <- liftIO $ readCache cache path
mb_command <- liftM (liftM (urlDecodeUnicode . UTF8.decodeString)) (getInput "command")
case mb_command of
Just "update_grammar"
-> do mb_pgf <- getFile
id <- getGrammarId
name <- getFileName
descr <- getDescription
userId <- getUserId
doUpdateGrammar c mb_pgf id name descr userId
Just "delete_grammar"
-> do id <- getGrammarId
userId <- getUserId
doDeleteGrammar c id userId
Just "grammars"
-> do userId <- getUserId
doGrammars c userId
Just "save" -> doSave c =<< getId
Just "load" -> doLoad c =<< getId
Just "search" -> doSearch c =<< getQuery
Just "delete" -> doDelete c =<< getIds
Just cmd -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show cmd]
Nothing -> do mb_uri <- getIdentity
mb_email <- getEMail
doLogin c mb_uri mb_email
where
getUserId :: CGI (Maybe String)
getUserId = getInput "userId"
getId :: CGI (Maybe Int)
getId = readInput "id"
getIds :: CGI [Int]
getIds = fmap (map read) (getMultiInput "id")
getQuery :: CGI String
getQuery = fmap (fromMaybe "") (getInput "query")
getGrammarId :: CGI String
getGrammarId = do
mb_url <- getInput "url"
return (maybe "null" (reverse . takeWhile (/='/') . drop 4 . reverse) mb_url)
getFile :: CGI (Maybe BS.ByteString)
getFile = do
getInputFPS "file"
getFileName :: CGI String
getFileName = do
mb_name0 <- getInput "name"
let mb_name | mb_name0 == Just "" = Nothing
| otherwise = mb_name0
mb_file <- getInputFilename "file"
return (fromMaybe "" (mb_name `mplus` mb_file))
getDescription :: CGI String
getDescription = fmap (fromMaybe "") (getInput "description")
getIdentity :: CGI (Maybe String)
getIdentity = getInput "openid.identity"
getEMail :: CGI (Maybe String)
getEMail = getInput "openid.ext1.value.email"
doLogin c mb_uri mb_email = do
path <- scriptName
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("call getUserId("++toSqlValue mb_uri++","++toSqlValue mb_email++")")
[id] <- collectRows getUserId s
return (Right id)
case r of
Right mb_id -> outputHTML (startupHTML mb_id mb_uri mb_email (Just path))
Left e -> throwCGIError 400 "Login failed" (lines (show e))
where
getUserId s = do
id <- getFieldValueMB s "userId"
return (id :: Maybe Int)
doGrammars c mb_userId = do
path <- scriptName
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("call getGrammars("++toSqlValue mb_userId++")")
rows <- collectRows (getGrammar path) s
return (Right rows)
case r of
Right rows -> outputJSONP rows
Left e -> throwCGIError 400 "Loading failed" (lines (show e))
where
getGrammar path s = do
id <- getFieldValue s "id"
name <- getFieldValue s "name"
description <- getFieldValue s "description"
return $ toJSObject [ ("url", showJSON (dropExtension path ++ '/':addExtension (show (id :: Int)) "pgf"))
, ("name", showJSON (name :: String))
, ("description", showJSON (description :: String))
]
doUpdateGrammar c mb_pgf id name descr mb_userId = do
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("call updateGrammar("++id++","++toSqlValue name++","++toSqlValue descr++","++toSqlValue mb_userId++")")
[id] <- collectRows (\s -> getFieldValue s "id") s
return (Right id)
nid <- case r of
Right id -> return (id :: Int)
Left e -> throwCGIError 400 "Saving failed" (lines (show e))
path <- pathTranslated
case mb_pgf of
Just pgf -> if pgf /= BS.empty
then liftIO (BS.writeFile (dropExtension path </> addExtension (show nid) "pgf") pgf)
else if id == "null"
then throwCGIError 400 "Grammar update failed" []
else return ()
Nothing -> return ()
outputHTML ""
doDeleteGrammar c id mb_userId = do
r <- liftIO $ handleSql (return . Left) $ do
execute c ("call deleteGrammar("++id++","++toSqlValue mb_userId++")")
return (Right "")
case r of
Right x -> outputJSONP ([] :: [(String,String)])
Left e -> throwCGIError 400 "Saving failed" (lines (show e))
doSave c mb_id = do
body <- getBody
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("call saveDocument("++toSqlValue mb_id++","++toSqlValue body++")")
[id] <- collectRows (\s -> getFieldValue s "id") s
return (Right id)
case r of
Right id -> outputJSONP (toJSObject [("id", id :: Int)])
Left e -> throwCGIError 400 "Saving failed" (lines (show e))
doLoad c Nothing = throwCGIError 400 "Loading failed" ["Missing ID"]
doLoad c (Just id) = do
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("SELECT id,title,created,modified,content\n"++
"FROM Documents\n"++
"WHERE id="++toSqlValue id)
rows <- collectRows getDocument s
return (Right rows)
case r of
Right [row] -> outputJSONP row
Right _ -> throwCGIError 400 "Missing document" ["ID="++show id]
Left e -> throwCGIError 400 "Loading failed" (lines (show e))
where
getDocument s = do
id <- getFieldValue s "id"
title <- getFieldValue s "title"
created <- getFieldValue s "created" >>= pt
modified <- getFieldValue s "modified" >>= pt
content <- getFieldValue s "content"
return $ toJSObject [ ("id", showJSON (id :: Int))
, ("title", showJSON (title :: String))
, ("created", showJSON (created :: String))
, ("modified", showJSON (modified :: String))
, ("content", showJSON (content :: String))
]
doSearch c q = do
r <- liftIO $ handleSql (return . Left) $ do
s <- query c ("SELECT id,title,created,modified\n"++
"FROM Documents"++
if null q
then ""
else "\nWHERE MATCH(content) AGAINST ("++toSqlValue q++" IN BOOLEAN MODE)")
rows <- collectRows getDocument s
return (Right rows)
case r of
Right rows -> outputJSONP rows
Left e -> throwCGIError 400 "Saving failed" (lines (show e))
where
getDocument s = do
id <- getFieldValue s "id"
title <- getFieldValue s "title"
created <- getFieldValue s "created" >>= pt
modified <- getFieldValue s "modified" >>= pt
return $ toJSObject [ ("id", showJSON (id :: Int))
, ("title", showJSON (title :: String))
, ("created", showJSON (created :: String))
, ("modified", showJSON (modified :: String))
]
pt ct = liftM (formatCalendarTime defaultTimeLocale "%d %b %Y") (toCalendarTime ct)
doDelete c ids = do
liftIO $
inTransaction c $ \c ->
mapM_ (\id -> execute c ("DELETE FROM Documents WHERE id = "++toSqlValue id)) ids
outputJSONP (toJSObject ([] :: [(String,String)]))
dbConnect fpath = do
[host,db,user,pwd] <- fmap words $ readFile fpath
connect host db user pwd
startupHTML mb_id mb_uri mb_email mb_path = unlines [
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">",
"<html>",
" <head>",
" <meta http-equiv=\"content-type\" content=\"text/html; charset=UTF-8\">",
" <title>Editor</title>",
" <script type=\"text/javascript\" language=\"javascript\" src=\"org.grammaticalframework.ui.gwt.EditorApp/org.grammaticalframework.ui.gwt.EditorApp.nocache.js\"></script>",
" </head>",
" <body onload=\"window.__gfInit = new Object(); "++
maybe "" (\id -> "window.__gfInit.userId = "++show id++"; ") mb_id++
maybe "" (\uri -> "window.__gfInit.userURI = '"++uri++"'; ") mb_uri++
maybe "" (\email -> "window.__gfInit.userEMail = '"++email++"'; ") mb_email++
maybe "" (\path -> "window.__gfInit.contentURL = '"++path++"'; ") mb_path++
"\">",
" <iframe src=\"javascript:''\" id=\"__gwt_historyFrame\" tabIndex='-1' style=\"position:absolute;width:0;height:0;border:0\"></iframe>",
" </body>",
"</html>"]
dbInit c =
handleSql (fail . show) $ do
inTransaction c $ \c -> do
execute c "DROP TABLE IF EXISTS GrammarUsers"
execute c "DROP TABLE IF EXISTS Users"
execute c "DROP TABLE IF EXISTS Grammars"
execute c "DROP TABLE IF EXISTS Documents"
execute c ("CREATE TABLE Users"++
" (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,\n"++
" identity VARCHAR(256) NOT NULL,\n"++
" email VARCHAR(128) NOT NULL,\n"++
" UNIQUE INDEX (identity))")
execute c ("CREATE TABLE Grammars"++
" (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,"++
" name VARCHAR(64) NOT NULL,\n"++
" description VARCHAR(512) NOT NULL,\n"++
" created TIMESTAMP NOT NULL DEFAULT 0,\n"++
" modified TIMESTAMP NOT NULL DEFAULT 0)")
execute c ("CREATE TABLE Documents"++
" (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,"++
" title VARCHAR(256) NOT NULL,\n"++
" created TIMESTAMP NOT NULL DEFAULT 0,\n"++
" modified TIMESTAMP NOT NULL DEFAULT 0,\n"++
" content TEXT NOT NULL,\n"++
" FULLTEXT INDEX (content)) TYPE=MyISAM")
execute c ("CREATE TABLE GrammarUsers"++
" (userId INTEGER NOT NULL,\n"++
" grammarId INTEGER NOT NULL,\n"++
" flags INTEGER NOT NULL,\n"++
" PRIMARY KEY (userId, grammarId),\n"++
" FOREIGN KEY (userId) REFERENCES Users(id) ON DELETE CASCADE,\n"++
" FOREIGN KEY (grammarId) REFERENCES Grammars(id) ON DELETE RESTRICT)")
execute c "DROP PROCEDURE IF EXISTS saveDocument"
execute c ("CREATE PROCEDURE saveDocument(IN id INTEGER, content TEXT)\n"++
"BEGIN\n"++
" IF id IS NULL THEN\n"++
" INSERT INTO Documents(title,content,created,modified) VALUES (content,content,NOW(),NOW());\n"++
" SELECT LAST_INSERT_ID() as id;\n"++
" ELSE\n"++
" UPDATE Documents d SET content = content, modified=NOW() WHERE d.id = id;\n"++
" select id;\n"++
" END IF;\n"++
"END")
execute c "DROP PROCEDURE IF EXISTS updateGrammar"
execute c ("CREATE PROCEDURE updateGrammar(IN id INTEGER, name VARCHAR(64), description VARCHAR(512), userId INTEGER)\n"++
"BEGIN\n"++
" IF id IS NULL THEN\n"++
" INSERT INTO Grammars(name,description,created,modified) VALUES (name,description,NOW(),NOW());\n"++
" SET id = LAST_INSERT_ID();\n"++
" INSERT INTO GrammarUsers(grammarId,userId,flags) VALUES (id,userId,0);\n"++
" ELSE\n"++
" UPDATE Grammars gr SET name = name, description=description, modified=NOW() WHERE gr.id = id;\n"++
" END IF;\n"++
" SELECT id;\n"++
"END")
execute c "DROP PROCEDURE IF EXISTS deleteGrammar"
execute c ("CREATE PROCEDURE deleteGrammar(IN aGrammarId INTEGER, aUserId INTEGER)\n"++
"BEGIN\n"++
" DECLARE deleted INTEGER;\n"++
" DELETE FROM GrammarUsers\n"++
" WHERE grammarId = aGrammarId AND userId = aUserId;\n"++
" IF NOT EXISTS(SELECT * FROM GrammarUsers gu WHERE gu.grammarId = aGrammarId) THEN\n"++
" DELETE FROM Grammars WHERE id = aGrammarId;\n"++
" SET deleted = 1;\n"++
" ELSE\n"++
" SET deleted = 0;\n"++
" END IF;\n"++
" SELECT deleted;\n"++
"END")
execute c "DROP PROCEDURE IF EXISTS getGrammars"
execute c ("CREATE PROCEDURE getGrammars(IN userId INTEGER)\n"++
"BEGIN\n"++
" SELECT g.id,g.name,g.description\n"++
" FROM Grammars g JOIN GrammarUsers gu ON g.id = gu.grammarId\n"++
" WHERE gu.userId = userId\n"++
" ORDER BY g.name;\n"++
"END")
execute c "DROP PROCEDURE IF EXISTS getUserId"
execute c ("CREATE PROCEDURE getUserId(identity VARCHAR(256), email VARCHAR(128))\n"++
"BEGIN\n"++
" DECLARE userId INTEGER;\n"++
" IF identity IS NULL OR email IS NULL THEN\n"++
" SET userId = NULL;\n"++
" ELSE\n"++
" SELECT id INTO userId FROM Users u WHERE u.identity = identity;\n"++
" IF userId IS NULL THEN\n"++
" INSERT INTO Users(identity, email) VALUES (identity, email);\n"++
" SET userId = LAST_INSERT_ID();\n"++
" END IF;\n"++
" END IF;\n"++
" SELECT userId;\n"++
"END")

88
src/server/exec/MorphoService.hs
View File

@@ -1,88 +0,0 @@
import GF.Compile
import GF.Compile.Rename (renameSourceTerm)
import GF.Compile.Concrete.Compute (computeConcrete)
import GF.Compile.Concrete.TypeCheck (inferLType)
import GF.Data.Operations
import GF.Grammar
import GF.Grammar.Parser
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Infra.Modules (greatestResource)
import GF.Infra.CheckM
import GF.Text.UTF8
import Network.FastCGI
import Text.JSON
import Text.PrettyPrint
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString)
import Data.ByteString.Char8 as BS
import Control.Monad
import System.Environment
import System.FilePath
import Cache
import FastCGIUtils
import URLEncoding
-- FIXME !!!!!!
grammarFile :: FilePath
grammarFile = "/usr/local/share/gf-3.1/lib/alltenses/ParadigmsFin.gfo"
grammarPath :: FilePath
grammarPath = "/usr/local/share/gf-3.1/lib/prelude"
main :: IO ()
main = do initFastCGI
r <- newCache readGrammar
loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r)))
fcgiMain :: Cache SourceGrammar -> CGI CGIResult
fcgiMain cache = liftIO (readCache cache grammarFile) >>= cgiMain
readGrammar :: FilePath -> IO SourceGrammar
readGrammar file =
do let opts = concatOptions [modifyFlags $ \fs -> fs { optVerbosity = Quiet },
modifyFlags $ \fs -> fs { optLibraryPath = [grammarPath] }]
mgr <- appIOE $ batchCompile opts [file]
err (fail "Grammar loading error") return mgr
cgiMain :: SourceGrammar -> CGI CGIResult
cgiMain sgr =
do path <- pathInfo
json <- case path of
"/eval" -> do mjson <- return (doEval sgr) `ap` getTerm
err (throwCGIError 400 "Evaluation error" . (:[])) return mjson
_ -> throwCGIError 404 "Not Found" ["Resource not found: " ++ path]
outputJSON json
where
getTerm :: CGI String
getTerm = do mt <- getInput "term"
maybe (throwCGIError 400 "No term given" ["No term given"]) (return . urlDecodeUnicode . UTF8.decodeString) mt
doEval :: SourceGrammar -> String -> Err JSValue
doEval sgr t = liftM termToJSValue $ eval sgr t
termToJSValue :: Term -> JSValue
termToJSValue t =
showJSON [toJSObject [("name", render name), ("value",render value)] | (name,value) <- ppTermTabular Unqualified t]
eval :: SourceGrammar -> String -> Err Term
eval sgr t =
case runP pExp (BS.pack t) of
Right t -> do mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr
(t,_) <- runCheck (renameSourceTerm sgr mo t)
((t,_),_) <- runCheck (inferLType sgr [] t)
computeConcrete sgr t
Left (_,msg) -> fail msg
-- * General CGI and JSON stuff
outputJSON :: JSON a => a -> CGI CGIResult
outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8"
outputStrict $ UTF8.encodeString $ encode x
outputStrict :: String -> CGI CGIResult
outputStrict x | x == x = output x
| otherwise = fail "I am the pope."

2
src/server/exec/pgf-http.hs
View File

@@ -7,7 +7,7 @@ import System.FilePath(takeExtension,takeFileName,takeDirectory,(</>))
import RunHTTP(runHTTP,Options(..))
import ServeStaticFile(serveStaticFile)
import PGFService(cgiMain',getPath,stderrToFile,logFile,newPGFCache)
import FastCGIUtils(outputJSONP,handleCGIErrors)
import CGIUtils(outputJSONP,handleCGIErrors)
import Paths_gf_server(getDataDir)

118
src/server/gf-server.cabal
View File

@@ -1,118 +0,0 @@
name: gf-server
version: 1.0
cabal-version: >= 1.8
build-type: Custom
license: GPL
license-file: ../../LICENSE
synopsis: FastCGI Server for Grammatical Framework
flag content
Description:
Build content service (requires fastcgi and hsql-mysql packages)
(In Ubuntu: apt-get install libghc-fastcgi-dev libghc-hsql-mysql-dev)
Default: False
flag http
Description: Build pgf-http (deprecated, replaced by gf -server)
Default: False
flag fastcgi
Description: Build librar & pgf-service executable with fastcgi support
Default: True
flag c-runtime
Description: Include functionality from the C run-time library (which must be installed already)
Default: False
flag network-uri
description: Get Network.URI from the network-uri package
default: True
Library
exposed-modules: PGFService FastCGIUtils CGIUtils ServeStaticFile RunHTTP Cache
other-modules: URLEncoding CGI Fold
hs-source-dirs: . transfer
if flag(fastcgi)
build-depends: fastcgi >= 3001.0.2.2
-- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
else
Buildable: False
build-depends: base >=4.2 && <5,
time, time-compat, old-locale,
directory,
filepath,
containers,
process,
gf >= 3.6,
cgi >= 3001.1.7.3,
httpd-shed>=0.4.0.2,
mtl,
exceptions,
json >= 0.3.3,
utf8-string >= 0.3.1.1,
bytestring,
pretty,
random
if flag(network-uri)
build-depends: network-uri>=2.6, network>=2.6
else
build-depends: network>=2.3 && <2.6
ghc-options: -fwarn-unused-imports
if os(windows)
ghc-options: -optl-mwindows
else
build-depends: unix
if flag(c-runtime)
cpp-options: -DC_RUNTIME
executable pgf-http
main-is: pgf-http.hs
Hs-source-dirs: exec
ghc-options: -threaded
if impl(ghc>=7.0)
ghc-options: -rtsopts
if flag(http)
buildable: True
build-depends: base >=4.2 && <5, gf-server, filepath, directory, cgi
else
buildable: False
executable pgf-service
main-is: pgf-fcgi.hs
Hs-source-dirs: exec
ghc-options: -threaded -fwarn-unused-imports
if impl(ghc>=7.0)
ghc-options: -rtsopts
if flag(fastcgi)
build-depends: fastcgi >= 3001.0.2.2
-- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
else
Buildable: False
build-depends: base >=4.2 && <5, gf-server
if os(windows)
ghc-options: -optl-mwindows
else
build-depends: unix
executable content-service
if flag(content)
build-depends: base >=4.2 && <5, old-locale,
fastcgi >= 3001.0.2.2,
-- In Ubuntu: apt-get install libghc-fastcgi-dev
hsql-mysql, hsql
-- In Ubuntu: apt-get install libghc-hsql-mysql-dev
buildable: True
else
buildable: False
main-is: ContentService.hs
Hs-source-dirs: exec

6
src/server/lighttpd.conf
View File

@@ -1,4 +1,4 @@
# Run with (with -D for no-daemon)
# Run with (with -D for no-daemon)
# /usr/sbin/lighttpd -f lighttpd.conf -D
#
@@ -10,8 +10,9 @@ server.modules = (
"mod_cgi"
)
var.basedir = var.CWD
var.basedir = var.CWD
# John: no longer valid after removing `src/ui` 2018-11-15
server.document-root = basedir + "/../ui/gwt/www"
server.errorlog = basedir + "/error.log"
@@ -96,4 +97,3 @@ static-file.exclude-extensions = ( ".php", ".pl", ".fcgi" )
## bind to port (default: 80)
server.port = 41296

102
src/tools/Htmls.hs
View File

@@ -1,102 +0,0 @@
----------------------------------------------------------------------
-- |
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/16 17:07:18 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- chop an HTML file into separate files, each linked to the next and previous.
-- the names of the files are n-file, with n = 01,02,...
-- the chopping is performed at each separator, here defined as @\<!-- NEW --\>@
--
-- AR 7\/1\/2002 for the Vinnova meeting in Linköping.
-- Added table of contents generation in file 00, 16/4/2005
-----------------------------------------------------------------------------
module Main (main) where
import System.Environment(getArgs)
import Data.Char
main :: IO ()
main = do
file:_ <- getArgs
htmls file
htmls :: FilePath -> IO ()
htmls file = do
s <- readFile file
let ss = allPages file s
lg = length ss
putStrLn $ show lg ++ " slides"
mapM_ (uncurry writeFile . mkFile file lg) ss
allPages :: FilePath -> String -> [(Int,String)]
allPages file s = addIndex $ zip [1..] $ map unlines $ chop lss where
chop ls = case span isNoSep ls of
(s,_:ss) -> s : chop ss
_ -> [ls]
isNoSep = (/= separator)
addIndex = ((0,mkIndex file lss) :)
lss = lines s
mkFile :: FilePath -> Int -> (Int,String) -> (FilePath,String)
mkFile base mx (number,content) =
(fileName base number,
unlines [
begHTML,
"<font size=1>",
pageNum mx number,
link base mx number,
"</font>",
"<p>",
content,
endHTML
]
)
begHTML, endHTML, separator :: String
begHTML = "<html><body bgcolor=\"#FFFFFF\" text=\"#000000\">"
endHTML = "</body></html>"
separator = "<!-- NEW -->"
link :: FilePath -> Int -> Int -> String
link file mx n =
(if n >= mx-1 then "" else (" <a href=\"" ++ file' ++ "\">Next</a>")) ++
(if n == 1 then "" else (" <a href=\"" ++ file_ ++ "\">Previous</a>")) ++
(" <a href=\"" ++ file0 ++ "\">Contents</a>") ++
(" <a href=\"" ++ file ++ "\">Fulltext</a>") ++
(" <a href=\"" ++ file1 ++ "\">First</a>") ++
(" <a href=\"" ++ file2 ++ "\">Last</a>")
where
file_ = fileName file (n - 1)
file' = fileName file (n + 1)
file0 = fileName file 0
file1 = fileName file 1
file2 = fileName file (mx - 1)
fileName :: FilePath -> Int -> FilePath
fileName file n = (if n < 10 then ('0':) else id) $ show n ++ "-" ++ file
pageNum mx num = "<p align=right>" ++ show num ++"/" ++ show (mx-1) ++ "</p>"
mkIndex file = unlines . mkInd 1 where
mkInd n ss = case ss of
s : rest | (s==separator) -> mkInd (n+1) rest
s : rest -> case getHeading s of
Just (i,t) -> mkLine n i t : mkInd n rest
_ -> mkInd n rest
_ -> []
getHeading s = case dropWhile isSpace s of
'<':h:i:_:t | isDigit i -> return (i,take (length t - 5) t) -- drop final </hi>
_ -> Nothing
mkLine _ '1' t = t ++ " : Table of Contents<p>" -- heading of whole document
mkLine n i t = stars i ++ link n t ++ "<br>"
stars i = case i of
'3' -> "<li> "
'4' -> "<li>* "
_ -> ""
link n t = "<a href=\"" ++ fileName file n ++ "\">" ++ t ++ "</a>"

4
src/tools/gf-tools.cabal
View File

@@ -6,7 +6,3 @@ cabal-version: >= 1.8
Executable gfdoc
main-is: GFDoc.hs
build-depends: base, directory>=1.2, time>=1.5, process
Executable htmls
main-is: Htmls.hs
build-depends: base

9
src/ui/android/.classpath
View File

@@ -1,9 +0,0 @@
<?xml version="1.0" encoding="UTF-8"?>
<classpath>
<classpathentry kind="src" path="src"/>
<classpathentry kind="src" path="gen"/>
<classpathentry kind="con" path="com.android.ide.eclipse.adt.ANDROID_FRAMEWORK"/>
<classpathentry exported="true" kind="con" path="com.android.ide.eclipse.adt.LIBRARIES"/>
<classpathentry exported="true" kind="con" path="com.android.ide.eclipse.adt.DEPENDENCIES"/>
<classpathentry kind="output" path="bin/classes"/>
</classpath>

33
src/ui/android/.project
View File

@@ -1,33 +0,0 @@
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
<name>GFTranslator</name>
<comment></comment>
<projects>
</projects>
<buildSpec>
<buildCommand>
<name>com.android.ide.eclipse.adt.ResourceManagerBuilder</name>
<arguments>
</arguments>
</buildCommand>
<buildCommand>
<name>com.android.ide.eclipse.adt.PreCompilerBuilder</name>
<arguments>
</arguments>
</buildCommand>
<buildCommand>
<name>org.eclipse.jdt.core.javabuilder</name>
<arguments>
</arguments>
</buildCommand>
<buildCommand>
<name>com.android.ide.eclipse.adt.ApkBuilder</name>
<arguments>
</arguments>
</buildCommand>
</buildSpec>
<natures>
<nature>com.android.ide.eclipse.adt.AndroidNature</nature>
<nature>org.eclipse.jdt.core.javanature</nature>
</natures>
</projectDescription>

63
src/ui/android/AndroidManifest.xml
View File

@@ -1,63 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="org.grammaticalframework.ui.android"
android:versionCode="15"
android:versionName="1.2.2"
android:installLocation="auto" >
<uses-sdk
android:minSdkVersion="11"
android:targetSdkVersion="18" />
<uses-permission android:name="android.permission.RECORD_AUDIO" />
<application
android:allowBackup="true"
android:icon="@drawable/ic_app"
android:label="@string/app_name"
android:theme="@style/AppTheme" android:name="GFTranslator">
<activity
android:name=".MainActivity"
android:label="@string/app_name" >
<intent-filter>
<action android:name="android.intent.action.MAIN" />
<category android:name="android.intent.category.LAUNCHER" />
</intent-filter>
</activity>
<activity android:name="AlternativesActivity">
<intent-filter>
<action android:name="android.intent.action.VIEW"/>
<category android:name="android.intent.category.DEFAULT"/>
<category android:name="android.intent.category.BROWSABLE"/>
<data android:scheme="gf-translator"/>
</intent-filter>
</activity>
<activity android:name="HelpActivity"></activity>
<activity android:name="SemanticGraphActivity"
android:launchMode="singleTop">
<intent-filter>
<action android:name="android.intent.action.SEARCH" />
</intent-filter>
<meta-data android:name="android.app.searchable"
android:resource="@xml/searchable"/>
<meta-data android:name="android.app.default_searchable"
android:value=".SearchableActivity"/>
</activity>
<activity android:name="se.chalmers.phrasebook.gui.activities.NavigationActivity"></activity>
<service android:name="TranslatorInputMethodService"
android:permission="android.permission.BIND_INPUT_METHOD">
<intent-filter>
<action android:name="android.view.InputMethod" />
</intent-filter>
<meta-data android:name="android.view.im" android:resource="@xml/method" />
</service>
<provider android:name=".LexiconSuggestionProvider"
android:authorities="org.grammaticalframework.ui.android.LexiconSuggestionProvider">
<path-permission android:pathPrefix="/search_suggest_query"
android:readPermission="android.permission.GLOBAL_SEARCH"/>
</provider>
</application>
</manifest>

27
src/ui/android/LICENSE
View File

@@ -1,27 +0,0 @@
BSD LICENSE
Copyright (c) 1998, Grammatical Framework
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the <organization> nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

68
src/ui/android/README
View File

@@ -1,68 +0,0 @@
= Overview =
This directory contains a sample Android app tht uses
the Android speech recognition and TTS APIs along with
JNI bindings to the C PGF runtime to implement a simple
speech translation app.
= Requirements =
1. Android SDK: http://developer.android.com/sdk/
installed in $ANDROID_SDK_LOCATION
2. Android NDK: http://developer.android.com/tools/sdk/ndk/
installed in $ANDROID_NDK_LOCATION
= Building =
Set up Android project:
# Creates local.properties, not to be checked in
$ $ANDROID_SDK_LOCATION/tools/android update project -p .
Build libs/libjpgf.jar:
$ (cd ../../runtime/java && javac org/grammaticalframework/*/*.java && jar -cf ../../ui/android/libs/jpgf.jar org/grammaticalframework/*/*.class)
Build JNI code:
$ cd jni
$ $ANDROID_NDK_LOCATION/ndk-build
Build the semantic database code:
$ runghc glosses.hs
Build APK:
$ ant debug
Install on your device:
$ ant debug install
or:
$ adb install -r bin/MainActivity-debug.apk
= Changing the grammar =
1. Replace assets/ResourceDemo.pgf
2. Edit Translator.java to point to the new file and include its metadata
= Developing in Eclipse =
1. Install Android ADT
2. Eclipse > File > Import > Existing Projects into Workspace > Next
3. Select root directory...
4. Select GF/src/ui/android
5. Finish

2
src/ui/android/ant.properties
View File

@@ -1,2 +0,0 @@
key.store=/home/krasimir/dg/src/keys/dg_keystore
key.alias=dg

157
src/ui/android/assets/help_content.html
View File

@@ -1,157 +0,0 @@
<html>
<body>
</p>
<b>GF Offline Translator</b>:
text and speech translation for 16 languages with
quality control. Version 19 April 2017 (beta).
</p>
<p>
<b>Speech input</b>: Tap microphone icon and talk while it is red.
<br>
<b>Text input</b>: Select "keyboard" from menu, tap keyboard icon.
<br>
<b>Correction</b>: Tap input text and edit.
<br>
<b>Alternatives</b>: Tap output text.
<br>
<b>Grammar info</b>: Tap any of the alternatives.
<br>
<b>Confidence</b>: colour of output text
<ul>
<li><span style="background-color:palegreen">Green</span>: semantic, probably correct (but has alternatives)</li>
<li><span style="background-color:yellow">Yellow</span>: syntactic, often incorrect (has alternatives)</li>
<li><span style="background-color:pink">Light red</span>: chunk-based, probably incorrect (has alternatives)</li>
<li><span style="background-color:red">Dark red</span>: word-based, often very bad</li>
</ul>
<br>
<b>Topics</b> (new, select from menu): Words grouped by semantic categories, with WordNet glosses.
<br>
<b>Phrasebook</b> (new, select from menu): Conceptual authoring with the green translations.
</p>
<hr>
<h2>More details</h2>
<p>
GF Offline Translator is based on grammar and semantics. It is compact in size
and gives control on quality. Its technology is inspired by compilers, which are
programs that translate computer languages.
Most other translators for human language are based on
statistics and have less control of quality and are much bigger, so that
they require either an internet connection or a huge storage on your phone.
</p>
The app indicates translation confidence with colours:
<ul>
<li><b>Green</b>:
semantic translation, should be correct.
But not necessarily the only correct one.
You can tap the output to see alternatives.
</li>
<li><b>Yellow</b>:
syntactic translation, should be grammatically correct.
But can be very strange in its interpretation and choice of words.
</li>
<li><b>Light red</b>:
chunk translation, probably incorrect.
Builds the translation from small pieces.
</li>
<li><b>Dark red</b>:
word-by-word translation, almost certainly incorrect.
Builds the translation word by word.
</li>
</ul>
The green translations come from a tourist phrasebook, which allows
you to translate things like "hello" and "how far is the airport from
the hotel".
</p>
<p>
You can translate both speech and text, as selected in the menu in the
upper right corner. Both kinds of input can be edited with the
keyboard by first tapping at the input field. This is often needed
because of <b>speech recognition errors</b>. Changing words
from <b>upper to lower case</b> may also be needed.
At the moment, <b>Japanese</b> and <b>Thai</b> input must be separated
to words, whereas Chinese works without spaces.
</p>
<p>
Translation works between any of the 16 supported languages, which means 240
language pairs in the current version. But different languages are on different levels of development.
The following table gives a rough idea of what to expect:
</p>
<p>
<center>
<table rules=all border=yes>
<tr> <th></th> <th>coverage</th> <th>quality</th> <th>speed</th> <th>speech</th> </tr>
<tr> <th>Bulgarian</th> <td bgcolor=yellow></td> <td bgcolor=yellow></td><td bgcolor=palegreen></td> <td bgcolor=yellow>in only</td></tr>
<tr> <th>Catalan</th> <td bgcolor=pink></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=yellow></td></tr>
<tr> <th>Chinese</th> <td bgcolor=pink></td> <td bgcolor=pink></td> <td bgcolor=palegreen></td> <td bgcolor=yellow></td> </tr>
<tr> <th>Dutch</th> <td bgcolor=yellow></td> <td bgcolor=yellow></td> <td bgcolor=yellow></td> <td bgcolor=palegreen></td> </tr>
<tr> <th>English</th> <td bgcolor=palegreen></td> <td bgcolor=palegreen></td> <td bgcolor=palegreen></td> <td bgcolor=palegreen></td> </tr>
<tr> <th>Estonian</th> <td bgcolor=yellow></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=red></td></tr>
<tr> <th>Finnish</th> <td bgcolor=yellow></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=yellow></td></tr>
<tr> <th>French</th> <td bgcolor=pink></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=palegreen></td></tr>
<tr> <th>German</th> <td bgcolor=pink></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=palegreen></td></tr>
<tr> <th>Hindi</th> <td bgcolor=pink></td> <td bgcolor=red></td> <td bgcolor=yellow></td> <td bgcolor=yellow></td> </tr>
<tr> <th>Italian</th> <td bgcolor=pink></td> <td bgcolor=pink></td><td bgcolor=pink></td> <td bgcolor=palegreen></td></tr>
<tr> <th>Japanese*</th><td bgcolor=pink></td> <td bgcolor=pink></td><td bgcolor=yellow></td> <td bgcolor=palegreen></td></tr>
<tr> <th>Russian</th> <td bgcolor=pink></td> <td bgcolor=red></td> <td bgcolor=yellow></td> <td bgcolor=yellow></td> </tr>
<tr> <th>Spanish</th> <td bgcolor=pink></td> <td bgcolor=yellow></td><td bgcolor=pink></td> <td bgcolor=palegreen></td></tr>
<tr> <th>Swedish</th> <td bgcolor=yellow></td> <td bgcolor=yellow></td> <td bgcolor=palegreen></td> <td bgcolor=yellow></td></tr>
<tr> <th>Thai*</th> <td bgcolor=pink></td> <td bgcolor=pink></td><td bgcolor=yellow></td> <td bgcolor=palegreen></td></tr>
</table>
</center>
* For translation from Japanese and Thai you need to separate each word with a space
</p>
<p>
The speech input and output use Google's voice services. Their status
can hence change without notice. You can make it more stable by
installing third-party speech tools, such as SVOX, which provides
output for most of the listed languages.
</p>
<p>
When you tap on a translation you get a screen with <b>alternative translations</b>.
Tapping on each of the alternatives
gives you <b>grammatical information</b>:
an inflection table, if it is a single word,
and a syntax tree otherwise.
</p>
<p>
The app also provides an <b>input method</b> which you can use as
an alternative keyboard which allows you to do translation from
other applications, for instance while you are entering SMS or e-mail.
To activate it go to Settings > Language &amp; input.
</p>
<p>
The translation works <b>completely off-line</b>, without
internet connection, when doing text-based translation.
Even speech works off-line in some languages,
but being on-line may give you better
speech input and output and more languages.
</p>
<p>
You can also install third-party off-line speech engines, such as
<a href="https://play.google.com/store/apps/developer?id=SVOX+Mobile+Voices&hl=en">SVOX</a>.
Consult the voice/language settings on your phone to find the optimal
speech engines, and restart the app after changing the settings.
</p>
<p>
The GF Offline Translator is powered by
<a href="http://www.grammaticalframework.org/">GF</a>, Grammatical Framework.
It is open-source software,
built by support from the GF community and from <a href="http://www.digitalgrammars.com/">Digital Grammars</a>.
</p>
<p>
<i>Digital Grammars is a company that can tailor this app to you needs and provide good
translation for the kind of vocabulary you need. Just tell us what you want to see
in the green area!</i>
</p>
</body>
</html>

1035
src/ui/android/assets/phrases.xml
View File

File diff suppressed because it is too large Load Diff

92
src/ui/android/build.xml
View File

@@ -1,92 +0,0 @@
<?xml version="1.0" encoding="UTF-8"?>
<project name="MainActivity" default="help">
<!-- The local.properties file is created and updated by the 'android' tool.
It contains the path to the SDK. It should *NOT* be checked into
Version Control Systems. -->
<property file="local.properties" />
<!-- The ant.properties file can be created by you. It is only edited by the
'android' tool to add properties to it.
This is the place to change some Ant specific build properties.
Here are some properties you may want to change/update:
source.dir
The name of the source directory. Default is 'src'.
out.dir
The name of the output directory. Default is 'bin'.
For other overridable properties, look at the beginning of the rules
files in the SDK, at tools/ant/build.xml
Properties related to the SDK location or the project target should
be updated using the 'android' tool with the 'update' action.
This file is an integral part of the build system for your
application and should be checked into Version Control Systems.
-->
<property file="ant.properties" />
<!-- if sdk.dir was not set from one of the property file, then
get it from the ANDROID_HOME env var.
This must be done before we load project.properties since
the proguard config can use sdk.dir -->
<property environment="env" />
<condition property="sdk.dir" value="${env.ANDROID_HOME}">
<isset property="env.ANDROID_HOME" />
</condition>
<!-- The project.properties file is created and updated by the 'android'
tool, as well as ADT.
This contains project specific properties such as project target, and library
dependencies. Lower level build properties are stored in ant.properties
(or in .classpath for Eclipse projects).
This file is an integral part of the build system for your
application and should be checked into Version Control Systems. -->
<loadproperties srcFile="project.properties" />
<!-- quick check on sdk.dir -->
<fail
message="sdk.dir is missing. Make sure to generate local.properties using 'android update project' or to inject it through the ANDROID_HOME environment variable."
unless="sdk.dir"
/>
<!--
Import per project custom build rules if present at the root of the project.
This is the place to put custom intermediary targets such as:
-pre-build
-pre-compile
-post-compile (This is typically used for code obfuscation.
Compiled code location: ${out.classes.absolute.dir}
If this is not done in place, override ${out.dex.input.absolute.dir})
-post-package
-post-build
-pre-clean
-->
<import file="custom_rules.xml" optional="true" />
<!-- Import the actual build file.
To customize existing targets, there are two options:
- Customize only one target:
- copy/paste the target into this file, *before* the
<import> task.
- customize it to your needs.
- Customize the whole content of build.xml
- copy/paste the content of the rules files (minus the top node)
into this file, replacing the <import> task.
- customize to your needs.
***********************
****** IMPORTANT ******
***********************
In all cases you must update the value of version-tag below to read 'custom' instead of an integer,
in order to avoid having your file be overridden by tools such as "android update project"
-->
<!-- version-tag: 1 -->
<import file="/Users/aarne/Library/Android/apache-ant-1.9.4/fetch.xml" />
</project>

60
src/ui/android/gf-translator-alignment.dot
View File

@@ -1,60 +0,0 @@
digraph {
rankdir=LR ;
node [shape = record] ;
bgcolor = "#FFFFFF00" ;
struct0[label = "<n0>твоят | <n1>телефон | <n2>може | <n3>да | <n4>превежда"] ;
struct0:n0:e -> struct1:n0:w ;
struct0:n1:e -> struct1:n1:w ;
struct0:n2:e -> struct1:n2:w ;
struct0:n4:e -> struct1:n3:w ;
struct1[label = "<n0>el teu | <n1>telèfon | <n2>sap | <n3>traduir"] ;
struct1:n0:e -> struct2:n0:w ;
struct1:n1:e -> struct2:n2:w ;
struct1:n2:e -> struct2:n3:w ;
struct1:n3:e -> struct2:n4:w ;
struct2[label = "<n0>你 | <n1>的 | <n2>电 话 | <n3>会 | <n4>翻 译"] ;
struct2:n0:e -> struct3:n0:w ;
struct2:n2:e -> struct3:n1:w ;
struct2:n3:e -> struct3:n2:w ;
struct2:n4:e -> struct3:n3:w ;
struct3[label = "<n0>je | <n1>telefoon | <n2>kan | <n3>vertalen"] ;
struct3:n0:e -> struct4:n0:w ;
struct3:n1:e -> struct4:n1:w ;
struct3:n2:e -> struct4:n2:w ;
struct3:n3:e -> struct4:n3:w ;
struct4[label = "<n0>your | <n1>phone | <n2>can | <n3>translate"] ;
struct4:n1:e -> struct5:n1:w ;
struct4:n2:e -> struct5:n2:w ;
struct4:n3:e -> struct5:n3:w ;
struct5[label = "<n1>puhelimesi | <n2>osaa | <n3>kääntää"] ;
struct5:n1:e -> struct6:n1:w ;
struct5:n2:e -> struct6:n2:w ;
struct5:n3:e -> struct6:n3:w ;
struct6[label = "<n0>ton | <n1>téléphone | <n2>sait | <n3>traduire"] ;
struct6:n0:e -> struct7:n0:w ;
struct6:n1:e -> struct7:n1:w ;
struct6:n2:e -> struct7:n2:w ;
struct6:n3:e -> struct7:n3:w ;
struct7[label = "<n0>dein | <n1>Telefon | <n2>kann | <n3>übersetzen"] ;
struct7:n0:e -> struct8:n0:w ;
struct7:n1:e -> struct8:n1:w ;
struct7:n2:e -> struct8:n3:w ;
struct7:n3:e -> struct8:n2:w ;
struct8[label = "<n0>तुम्हारा | <n1>फोन | <n2>अनुवाद कर | <n3>सकता | <n4>है"] ;
struct8:n0:e -> struct9:n1:w ;
struct8:n1:e -> struct9:n2:w ;
struct8:n2:e -> struct9:n4:w ;
struct8:n3:e -> struct9:n3:w ;
struct9[label = "<n0>il | <n1>tuo | <n2>telefono | <n3>sa | <n4>tradurre"] ;
struct9:n1:e -> struct10:n0:w ;
struct9:n2:e -> struct10:n1:w ;
struct9:n3:e -> struct10:n2:w ;
struct9:n4:e -> struct10:n3:w ;
struct10[label = "<n0>tu | <n1>teléfono | <n2>sabe | <n3>traducir"] ;
struct10:n0:e -> struct11:n0:w ;
struct10:n1:e -> struct11:n1:w ;
struct10:n2:e -> struct11:n2:w ;
struct10:n3:e -> struct11:n3:w ;
struct11[label = "<n0>din | <n1>telefon | <n2>kan | <n3>översätta"] ;
}

28
src/ui/android/gf-translator.svg
View File

@@ -1,28 +0,0 @@
<?xml version="1.0" standalone="no"?>
<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
<?xml-stylesheet type="text/css" href="http://fonts.googleapis.com/css?family=Inconsolata"?>
<svg width="1024" height="500" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<filter id="A"><feGaussianBlur stdDeviation="2"/></filter>
<defs>
<linearGradient id="grad1" x1="0%" y1="0%" x2="0%" y2="100%">
<stop offset="0%" style="stop-color:#a8d8ff;stop-opacity:1" />
<stop offset="100%" style="stop-color:#f6f6f6;stop-opacity:1" />
</linearGradient>
</defs>
<rect width="1024" height="500" style="fill:url(#grad1)"/>
<path filter="url(#A)"
d="M120,270 v-51 h59 m-59,0 v-53 h114 a110.5,105 0 1,1 -24,-66"
fill="none" stroke="black" stroke-width="4" opacity="0.25"
stroke-linejoin="round" stroke-linecap="round"/>
<path d="M120,270 v-51 h59 m-59,0 v-53 h114 a110.5,105 0 1,1 -24,-66"
fill="none" stroke="red" stroke-width="4"
stroke-linejoin="round" stroke-linecap="round"/>
<text x="310" y="120" font-size="70" font-family="Inconsolata">Offline Translation</text>
<text x="600" y="170" font-size="35" font-family="Inconsolata">with</text>
<text x="270" y="240" font-size="70" font-family="Inconsolata" fill="black" opacity="0.25" filter="url(#A)">Grammatical Framework</text>
<text x="270" y="240" font-size="70" font-family="Inconsolata" fill="#06c">Grammatical Framework</text>
<image x="0" y="270" width="1024" height="200"
xlink:href="gf-translator-alignment.png" />
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 1.6 KiB

46
src/ui/android/glosses.hs
View File

@@ -1,46 +0,0 @@
import SG
import PGF2
import Data.Char
import Data.List
main = do
db <- openSG "assets/semantics.db"
inTransaction db $ do
ls <- fmap lines $ readFile "../../../lib/src/translator/Dictionary.gf"
let glosses = [x | Just (fn,gloss) <- map gloss ls, x <- glossTriples fn gloss]
topics <- fmap (map toTriple . lines) $ readFile "topics.txt"
sequence_ [insertTriple db s p o | (s,p,o) <- glosses++topics]
closeSG db
toTriple l =
case readTriple l of
Just t -> t
Nothing -> error ("topics.txt: "++l)
gloss l =
case words l of
("fun":fn:_) -> case dropWhile (/='\t') l of
'\t':l -> Just (fn,l)
_ -> Nothing
_ -> Nothing
glossTriples fn s =
(if null gs then [] else [(fn_e,gloss,mkStr (merge gs))])++
(if null es then [] else [(fn_e,example,mkStr (merge (map (init . tail) es)))])
where
fn_e = mkApp fn []
gloss = mkApp "gloss" []
example = mkApp "example" []
(es,gs) = partition isExample (splitGloss s)
splitGloss s =
let (xs,s') = break (==';') s
in trim xs : case s' of
';':s -> splitGloss s
_ -> []
where
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
merge = intercalate "; "
isExample s = not (null s) && head s == '"' && last s == '"'

10
src/ui/android/hlc.svg
View File

@@ -1,10 +0,0 @@
<?xml version="1.0" standalone="no"?>
<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
<?xml-stylesheet type="text/css" href="http://fonts.googleapis.com/css?family=Inconsolata"?>
<svg width="250" height="250" version="1.1" xmlns="http://www.w3.org/2000/svg">
<desc>Digital Grammar Logo</desc>
<path d="M205,200 a110,110 0 1,1 0,-150 M125,15 v110 h80 M165,95 v60 M205,95 v60" fill="none" stroke="red" stroke-width="14" stroke-linejoin="round" stroke-linecap="round"/>
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 529 B

28
src/ui/android/jni/Android.mk
View File

@@ -1,28 +0,0 @@
LOCAL_PATH := $(call my-dir)
include $(CLEAR_VARS)
jni_c_files := jpgf.c jsg.c jni_utils.c
sg_c_files := sg.c sqlite3Btree.c
pgf_c_files := data.c expr.c graphviz.c linearizer.c literals.c parser.c parseval.c pgf.c printer.c reader.c \
reasoner.c evaluator.c jit.c typechecker.c lookup.c aligner.c writer.c
gu_c_files := assert.c choice.c exn.c fun.c in.c map.c out.c utf8.c \
bits.c defs.c enum.c file.c hash.c mem.c prime.c seq.c string.c ucs.c variant.c
LOCAL_MODULE := jpgf
LOCAL_SRC_FILES := $(addprefix ../../../runtime/java/, $(jni_c_files)) \
$(addprefix ../../../runtime/c/sg/, $(sg_c_files)) \
$(addprefix ../../../runtime/c/pgf/, $(pgf_c_files)) \
$(addprefix ../../../runtime/c/gu/, $(gu_c_files))
LOCAL_C_INCLUDES := ../../../runtime/c
include $(BUILD_SHARED_LIBRARY)
$(realpath ../obj/local/armeabi/objs/jpgf/__/__/__/runtime/c/pgf/jit.o): lightning
$(realpath ../obj/local/armeabi/objs-debug/jpgf/__/__/__/runtime/c/pgf/jit.o): lightning
lightning:
ln -s -f arm/asm.h ../../../runtime/c/pgf/lightning/asm.h
ln -s -f arm/core.h ../../../runtime/c/pgf/lightning/core.h
ln -s -f arm/fp.h ../../../runtime/c/pgf/lightning/fp.h
ln -s -f arm/funcs.h ../../../runtime/c/pgf/lightning/funcs.h

3
src/ui/android/jni/Application.mk
View File

@@ -1,3 +0,0 @@
APP_PLATFORM := android-8
APP_CFLAGS := -std=gnu99
APP_OPTIM := release

20
src/ui/android/proguard-project.txt
View File

@@ -1,20 +0,0 @@
# To enable ProGuard in your project, edit project.properties
# to define the proguard.config property as described in that file.
#
# Add project specific ProGuard rules here.
# By default, the flags in this file are appended to flags specified
# in ${sdk.dir}/tools/proguard/proguard-android.txt
# You can edit the include path and order by changing the ProGuard
# include property in project.properties.
#
# For more details, see
# http://developer.android.com/guide/developing/tools/proguard.html
# Add any project specific keep options here:
# If your project uses WebView with JS, uncomment the following
# and specify the fully qualified class name to the JavaScript interface
# class:
#-keepclassmembers class fqcn.of.javascript.interface.for.webview {
# public *;
#}

14
src/ui/android/project.properties
View File

@@ -1,14 +0,0 @@
# This file is automatically generated by Android Tools.
# Do not modify this file -- YOUR CHANGES WILL BE ERASED!
#
# This file must be checked in Version Control Systems.
#
# To customize properties used by the Ant build system edit
# "ant.properties", and override values to adapt the script to your
# project structure.
#
# To enable ProGuard to shrink and obfuscate your code, uncomment this (available properties: sdk.dir, user.home):
#proguard.config=${sdk.dir}/tools/proguard/proguard-android.txt:proguard-project.txt
# Project target.
target=android-21

BIN
src/ui/android/res/drawable-hdpi/btn_close.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.2 KiB

BIN
src/ui/android/res/drawable-hdpi/close_arrow.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 9.4 KiB

BIN
src/ui/android/res/drawable-hdpi/ic_action_switch.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 436 B

BIN
src/ui/android/res/drawable-hdpi/ic_app.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.4 KiB

BIN
src/ui/android/res/drawable-hdpi/ic_drawer.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 2.8 KiB

BIN
src/ui/android/res/drawable-hdpi/ic_keyboard.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 695 B

Some files were not shown because too many files have changed in this diff Show More