diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index f7fc3f18f..f49908db9 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/src/GF/Canon/CanonToGFCC.hs @@ -182,7 +182,7 @@ paramValues cgr = (labels,untyps,typs) where [(cat,ls) | (_,(cat,CncCat (RecType ls) _ _)) <- jments] labels = Map.fromList $ concat [((cat,[lab]),(typ,i)): - [((cat,[lab2,lab]),(ty,j)) | + [((cat,[lab,lab2]),(ty,j)) | rs <- getRec typ, (Lbg lab2 ty,j) <- zip rs [0..]] | (cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]] @@ -197,7 +197,7 @@ paramValues cgr = (labels,untyps,typs) where term2term :: CanonGrammar -> ParamEnv -> Term -> Term term2term cgr env@(labels,untyps,typs) tr = case tr of Par _ _ -> mkValCase tr - R rs | any (isStr . trmAss) rs -> + R rs -> ---- | any (isStr . trmAss) rs -> R [Ass (mkLab i) (t2t t) | (i,Ass l t) <- zip [0..] rs, not (isLock l t)] R rs -> valNum tr P t l -> r2r tr @@ -219,7 +219,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of Arg (A cat _) -> return (cat,[]) P p lab2 -> do (cat,labs) <- getLab p - return (cat,lab2:labs) + return (cat,labs++[lab2]) S p _ -> getLab p _ -> Bad "getLab" @@ -249,7 +249,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of let tr' = LI $ identC $ show k let tyvs = case Map.lookup (cat,lab) labels of Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,Map.keys vs) + Just vs -> (ty,[t | + (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) (Map.assocs vs)]) _ -> error $ A.prt ty _ -> error $ A.prt tr updateSTM ((tyvs, (tr', tr)):) diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 0c38a3826..9571d7c23 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -27,11 +27,11 @@ statGFCC gfcc = unlines [ type Concr = Map CId Term -lookMap :: (Show i, Ord i) => i -> Map i a -> a -lookMap c m = maybe (error ("cannot find " ++ show c)) id $ Data.Map.lookup c m +lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a +lookMap d c m = maybe d id $ Data.Map.lookup c m lookLin :: GFCC -> CId -> CId -> Term -lookLin mcfg lang fun = lookMap fun $ lookMap lang $ concretes mcfg +lookLin mcfg lang fun = lookMap term0 fun $ lookMap undefined lang $ concretes mcfg linearize :: GFCC -> CId -> Exp -> String linearize mcfg lang = realize . linExp mcfg lang @@ -57,6 +57,12 @@ linExp mcfg lang tree@(Tr at trees) = comp = compute mcfg lang look = lookLin mcfg lang +exp0 :: Exp +exp0 = Tr (AS "NO_PARSE") [] + +term0 :: Term +term0 = kks "UNKNOWN_ID" + kks :: String -> Term kks = K . KS @@ -81,7 +87,7 @@ compute mcfg lang args = compg [] where W s t -> W s (comp t) R ts -> R $ Prelude.map comp ts V i -> idx args (fromInteger i) -- already computed - S ts -> S (Prelude.map comp ts) + S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts F c -> comp $ look c -- global const: not comp'd (if contains argvar) FV ts -> FV $ Prelude.map comp ts _ -> trm diff --git a/src/GF/Canon/GFCC/RunGFCC.hs b/src/GF/Canon/GFCC/RunGFCC.hs index a013d7ccb..5caa5e8d2 100644 --- a/src/GF/Canon/GFCC/RunGFCC.hs +++ b/src/GF/Canon/GFCC/RunGFCC.hs @@ -39,9 +39,11 @@ treat grammar s = case words s of _ -> putStrLn "no parse found" _ -> lins $ readExp s where - lins t = mapM_ (lin t) $ cncnames grammar + lins t = mapM_ (lint t) $ cncnames grammar + lint t lang = do + putStrLn $ printTree $ linExp grammar lang t + lin t lang lin t lang = do - -- putStrLn $ printTree $ linExp grammar lang t putStrLn $ linearize grammar lang t prlins t = do putStrLn $ printTree t @@ -54,7 +56,7 @@ file2gfcc f = readFile f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer readExp :: String -> Exp -readExp = err (error "no parse") id . (pExp . myLexer) +readExp = errVal exp0 . (pExp . myLexer) {- diff --git a/src/GF/Canon/GFCC/Test.gf b/src/GF/Canon/GFCC/Test.gf index 6cbbd367c..efb77eff6 100644 --- a/src/GF/Canon/GFCC/Test.gf +++ b/src/GF/Canon/GFCC/Test.gf @@ -24,6 +24,7 @@ lincat VP = Verb ; oper Noun = {s : NForm => Str} ; oper Verb = {s : VForm => Str} ; +-- {- lincat NP = {s : Case => Str ; n : Number ; p : Person} ; lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.n np.p} ; lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.n np.p ++ ob.s ! Part} ; @@ -31,16 +32,19 @@ lin Det no = {s = \\c => no.s ! NF Sg c ; n = Sg ; p = P3} ; lin Dets no = {s = \\c => no.s ! NF Pl c ; n = Pl ; p = P3} ; lin Mina = {s = table Case ["minä" ; "minua"] ; n = Sg ; p = P1} ; lin Te = {s = table Case ["te" ; "teitä"] ; n = Pl ; p = P2} ; ---lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ; ---lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ; ---lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ; ---lin Det no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ; ---lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; ---lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ; ---lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ; +-- -} +{- +lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ; +lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ; +lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ; +lin Det no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ; +lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; +lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ; +lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ; +-} -lin Raha = mkN "raha" ; +lin Raha = mkN "raha" ; lin Paska = mkN "paska" ; lin Pallo = mkN "pallo" ; lin Puhua = mkV "puhu" ;