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

gfcc from GF now works for LangEng (except literals)

Browse Source
This commit is contained in:
aarne
2007-10-02 11:15:00 +00:00
parent 2202cf3ef5
commit dabf5d1ee0
5 changed files with 107 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
devel/koe/Koe.gf
View File

@@ -5,7 +5,7 @@ cat S ; NP ; VP ;
fun
Pred : NP -> VP -> S ;
He, She : NP ;
Je, Tu, Il, Elle, Nous, Vous, Ils, Elles : NP ;
Strong : VP ;

25
devel/koe/KoeFre.gf
View File

@@ -3,16 +3,21 @@ concrete KoeFre of Koe = {
param
Gen = Masc | Fem ;
Num = Sg | Pl ;
Per = P1 | P2 | P3 ;
oper
Agr : Type = {g : Gen ; n : Num} ;
Agr : Type = {g : Gen ; n : Num ; p : Per} ;
predA : Str -> {s : Agr => Str} = \adj ->
{s = \\a => copula a.n ++ regA adj a.g a.n} ;
{s = \\a => copula a.n a.p ++ regA adj a.g a.n} ;
copula : Num -> Str = \n -> case n of {
Sg => "est" ;
Pl => "sont"
copula : Num -> Per -> Str = \n,p -> case <n,p> of {
<Sg,P1> => "suis" ;
<Sg,P2> => "es" ;
<Sg,P3> => "est" ;
<Pl,P1> => "sommes" ;
<Pl,P2> => "êtes" ;
<Pl,P3> => "sont"
} ;
regA : Str -> Gen -> Num -> Str = \s,g,n -> case <g,n> of {
@@ -29,8 +34,14 @@ lincat
lin
Pred np vp = {s = np.s ++ vp.s ! np.a} ;
He = {s = "il" ; a = {g = Masc ; n = Sg}} ;
She = {s = "elle" ; a = {g = Fem ; n = Sg}} ;
Je = {s = "je" ; a = {g = Masc ; n = Sg ; p = P1}} ;
Tu = {s = "tu" ; a = {g = Masc ; n = Sg ; p = P2}} ;
Il = {s = "il" ; a = {g = Masc ; n = Sg ; p = P3}} ;
Elle = {s = "elle" ; a = {g = Fem ; n = Sg ; p = P3}} ;
Nous = {s = "nous" ; a = {g = Masc ; n = Pl ; p = P1}} ;
Vous = {s = "vous" ; a = {g = Masc ; n = Pl ; p = P2}} ;
Ils = {s = "ils" ; a = {g = Masc ; n = Pl ; p = P3}} ;
Elles = {s = "elles" ; a = {g = Fem ; n = Pl ; p = P3}} ;
Strong = predA "fort" ;

87
src/GF/Canon/GFCC/CheckGFCC.hs
View File

@@ -29,50 +29,62 @@ checkLin gfcc lang (f,t) =
labelBoolIO ("happened in function " ++ printTree f) $
checkTerm (lintype gfcc lang f) $ inline gfcc lang t
inferTerm :: [Tpe] -> Term -> Maybe Tpe
inferTerm :: [Tpe] -> Term -> Err Tpe
inferTerm args trm = case trm of
K _ -> return str
C i -> return $ ints i
V i -> if i < length args
then (return $ args !! i)
else error ("index " ++ show i)
V i -> do
testErr (i < length args) ("too large index " ++ show i)
return $ args !! i
S ts -> do
tys <- mapM infer ts
if all (==str) tys
then return str
else error ("only strings expected in: " ++ printTree trm
++ " instead of " ++ unwords (map printTree tys)
)
let tys' = filter (/=str) tys
testErr (null tys')
("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys'))
return str
R ts -> do
tys <- mapM infer ts
return $ tuple tys
P t u -> do
R tys <- infer t
case u of
tt <- infer t
tu <- infer u
case tt of
R tys -> case tu of
R [v] -> infer $ P t v
R (v:vs) -> infer $ P (head tys) (R vs) -----
C i -> if (i < length tys)
then (return $ tys !! i) -- record: index must be known
else error ("too few fields in " ++ printTree (R tys))
_ -> if all (==head tys) tys -- table: must be same
then return (head tys)
else error ("projection " ++ printTree trm)
FV ts -> return $ head ts ---- empty variants; check equality
C i -> do
testErr (i < length tys)
("required more than " ++ show i ++ " fields in " ++ prt (R tys))
(return $ tys !! i) -- record: index must be known
_ -> do
let typ = head tys
testErr (all (==typ) tys) ("different types in table " ++ prt trm)
return typ -- table: must be same
_ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
FV [] -> return str ----
FV (t:ts) -> do
ty <- infer t
tys <- mapM infer ts
testErr (all (==ty) tys) ("different types in variants " ++ prt trm)
return ty
W s r -> infer r
_ -> error ("no type inference for " ++ printTree trm)
_ -> Bad ("no type inference for " ++ prt trm)
where
infer = inferTerm args
prt = printTree
checkTerm :: LinType -> Term -> IO Bool
checkTerm (args,val) trm = case inferTerm args trm of
Just ty -> if eqType ty val then return True else do
Ok ty -> if eqType ty val
then return True
else do
putStrLn $ "term: " ++ printTree trm ++
"\nexpected type: " ++ printTree val ++
"\ninferred type: " ++ printTree ty
return False
_ -> do
putStrLn $ "cannot infer type of " ++ printTree trm
Bad s -> do
putStrLn s
return False
eqType :: Tpe -> Tpe -> Bool
@@ -117,14 +129,31 @@ inline gfcc lang t = case t of
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
composOp f trm = case trm of
R ts -> liftM R $ mapM comp ts
S ts -> liftM S $ mapM comp ts
FV ts -> liftM FV $ mapM comp ts
P t u -> liftM2 P (comp t) (comp u)
W s t -> liftM (W s) $ comp t
R ts -> liftM R $ mapM f ts
S ts -> liftM S $ mapM f ts
FV ts -> liftM FV $ mapM f ts
P t u -> liftM2 P (f t) (f u)
W s t -> liftM (W s) $ f t
_ -> return trm
where
comp = composOp f
composSafeOp :: (Term -> Term) -> Term -> Term
composSafeOp f = maybe undefined id . composOp (return . f)
-- from GF.Data.Oper
maybeErr :: String -> Maybe a -> Err a
maybeErr s = maybe (Bad s) Ok
testErr :: Bool -> String -> Err ()
testErr cond msg = if cond then return () else Bad msg
errVal :: a -> Err a -> a
errVal a = err (const a) id
errIn :: String -> Err a -> Err a
errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
err :: (String -> b) -> (a -> b) -> Err a -> b
err d f e = case e of
Ok a -> f a
Bad s -> d s

9
src/GF/Canon/GFCC/DataGFCC.hs
View File

@@ -1,6 +1,7 @@
module GF.Canon.GFCC.DataGFCC where
import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.PrintGFCC
import Data.Map
import Data.List
import Debug.Trace ----
@@ -92,10 +93,14 @@ compute mcfg lang args = comp where
look = lookLin mcfg lang
idx xs i = if i > length xs - 1 then trace "overrun !!\n" (last xs) else xs !! i
idx xs i = if i > length xs - 1
then trace
("too large " ++ show i ++ " for\n" ++ unlines (Prelude.map prt xs) ++ "\n") TM
else xs !! i
proj r p = case (r,p) of
(_, FV ts) -> FV $ Prelude.map (proj r) ts
(FV ts, _ ) -> FV $ Prelude.map (\t -> proj t r) ts
(W s t, _) -> kks (s ++ getString (proj t p))
(_,R is) -> comp $ foldl P r is
_ -> comp $ getField r (getIndex p)
@@ -116,6 +121,8 @@ compute mcfg lang args = comp where
TM -> TM
_ -> trace ("ERROR in grammar compiler: field from " ++ show t) t
prt = printTree
mkGFCC :: Grammar -> GFCC
mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
absname = a,

34
src/GF/Devel/GrammarToGFCC.hs
View File

@@ -10,6 +10,7 @@ import qualified GF.Grammar.Macros as GM
import qualified GF.Infra.Modules as M
import qualified GF.Infra.Option as O
import GF.Devel.PrGrammar
import GF.Devel.ModDeps
import GF.Infra.Ident
import GF.Infra.Option
@@ -38,7 +39,9 @@ mkCanon2gfcc opts cnc gr =
canon2gfcc :: Options -> SourceGrammar -> C.Grammar
canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where
(if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $
C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs
where
cs = map (i2i . fst) cms
adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) |
(f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
@@ -66,7 +69,7 @@ mkCType t = case t of
EInt i -> C.C $ fromInteger i
RecType rs -> C.R [mkCType t | (_, t) <- rs]
Table pt vt -> case pt of
EInt i -> C.R $ replicate (fromInteger i) $ mkCType vt
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
RecType rs -> mkCType $ foldr Table vt (map snd rs)
Sort "Str" -> C.S [] --- Str only
_ -> error $ "mkCType " ++ show t
@@ -150,7 +153,7 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs
where
recollect =
M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where
cl2cl cg = {- tr $ -} M.MGrammar $ map c2c $ M.modules cg where
c2c (c,m) = case m of
M.ModMod mo@(M.Module _ _ _ _ _ js) ->
(c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
@@ -202,7 +205,7 @@ paramValues cgr = (labels,untyps,typs) where
]
typsFrom ty = case ty of
Table p t -> typsFrom p ++ typsFrom t
RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls]
RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
_ -> [ty]
typsFromTrm :: Term -> STM [Type] Term
@@ -210,6 +213,8 @@ paramValues cgr = (labels,untyps,typs) where
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
T (TTyped ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
T (TComp ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm tr
jments =
@@ -244,7 +249,7 @@ type2type cgr env@(labels,untyps,typs) ty = case ty of
_ -> ty
where
t2t = type2type cgr env
look ty = EInt $ toInteger $ case Map.lookup ty typs of
look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
Just vs -> length $ Map.assocs vs
_ -> trace ("unknown partype " ++ show ty) 66669
@@ -253,12 +258,13 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
App _ _ -> mkValCase tr
QC _ _ -> mkValCase tr
R rs -> R [(mkLab i, (Nothing, t2t t)) |
(i,(l,(_,t))) <- zip [0..] (unlock rs)]
(i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
P t l -> r2r tr
PI t l i -> EInt $ toInteger i
T (TTyped ty) cs -> mkCurry $ V ty [t2t t | (_, t) <- cs]
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
S t p -> S (t2t t) (t2t p)
S t p -> mkCurrySel (t2t t) (t2t p)
_ -> GM.composSafeOp t2t tr
where
t2t = term2term cgr env
@@ -321,9 +327,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
Just v -> EInt v
_ -> valNumFV $ tryVar tr
_ -> valNumFV $ tryVar tr
tryVar tr = case tr of
----- Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)]
FV ts -> ts
tryVar tr = case GM.appForm tr of
---(c, ts) -> [ts' | ts' <- combinations (map tryVar ts)]
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of
[tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
@@ -332,7 +338,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
mkCurry trm = case trm of
V (RecType [(_,ty)]) ts -> V ty ts
V (RecType ((_,ty):ltys)) ts ->
V ty [mkCurry (V (RecType ltys) cs) | cs <- chop (lengthtyp ty) ts]
V ty [mkCurry (V (RecType ltys) cs) |
cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
_ -> trm
lengthtyp ty = case Map.lookup ty typs of
Just m -> length (Map.assocs m)
@@ -342,6 +349,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
(xs1,xs2) -> xs1:chop i xs2
mkCurrySel t p = S t p ----
mkLab k = LIdent (("_" ++ show k))