From 3edc8dfeac4946ef59ae7b5f1464676d3fd812f7 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 5 Oct 2007 08:17:27 +0000 Subject: [PATCH] shifted to use general trees and types (with macros for c-f) --- src/GF/Devel/GrammarToGFCC.hs | 7 ++++--- src/GF/GFCC/CheckGFCC.hs | 31 +++++++++++++++---------------- src/GF/GFCC/DataGFCC.hs | 2 +- src/GF/GFCC/Generate.hs | 8 ++++---- src/GF/GFCC/Macros.hs | 14 ++++++++++++++ 5 files changed, 38 insertions(+), 24 deletions(-) diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index b10cab877..0a59a8920 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -3,6 +3,7 @@ module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look +import qualified GF.GFCC.Macros as CM import qualified GF.GFCC.AbsGFCC as C import qualified GF.GFCC.DataGFCC as D import qualified GF.Grammar.Abstract as A @@ -47,14 +48,14 @@ canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = cns = map (i2i . fst) cms abs = D.Abstr aflags funs cats catfuns aflags = Map.fromAscList [] ---- flags - lfuns = [(f', (mkType ty,C.Tr (C.AC f') [])) | ---- defs + lfuns = [(f', (mkType ty,CM.tree (C.AC f') [])) | ---- defs (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] funs = Map.fromAscList lfuns lcats = [(i2i c,[]) | ---- context (c,AbsCat _ _) <- tree2list (M.jments abm)] cats = Map.fromAscList lcats catfuns = Map.fromAscList - [(cat,[f | (f, (C.Typ _ c,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] cncs = Map.fromList [mkConcr (i2i lang) mo | (lang,M.ModMod mo) <- cms] mkConcr lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames) @@ -74,7 +75,7 @@ i2i (IC c) = C.CId c mkType :: A.Type -> C.Type mkType t = case GM.catSkeleton t of - Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c) + Ok (cs,c) -> CM.cftype (map (i2i . snd) cs) (i2i $ snd c) mkCType :: Type -> C.Term mkCType t = case t of diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs index 860a90212..12f92bcac 100644 --- a/src/GF/GFCC/CheckGFCC.hs +++ b/src/GF/GFCC/CheckGFCC.hs @@ -1,8 +1,8 @@ module GF.GFCC.CheckGFCC where +import GF.GFCC.Macros import GF.GFCC.DataGFCC import GF.GFCC.AbsGFCC -import GF.GFCC.PrintGFCC import GF.GFCC.ErrM import qualified Data.Map as Map @@ -24,7 +24,7 @@ checkGFCC gfcc = do checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool) checkConcrete gfcc (lang,cnc) = - labelBoolIO ("happened in language " ++ printTree lang) $ do + labelBoolIO ("happened in language " ++ prt lang) $ do (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip return ((lang,cnc{lins = Map.fromAscList rs}),and bs) where @@ -32,11 +32,11 @@ checkConcrete gfcc (lang,cnc) = checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool) checkLin gfcc lang (f,t) = - labelBoolIO ("happened in function " ++ printTree f) $ do + labelBoolIO ("happened in function " ++ prt f) $ do (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t return ((f,t'),b) -inferTerm :: [Tpe] -> Term -> Err (Term,Tpe) +inferTerm :: [CType] -> Term -> Err (Term,CType) inferTerm args trm = case trm of K _ -> returnt str C i -> returnt $ ints i @@ -81,22 +81,21 @@ inferTerm args trm = case trm of where returnt ty = return (trm,ty) infer = inferTerm args - prt = printTree checkTerm :: LinType -> Term -> IO (Term,Bool) checkTerm (args,val) trm = case inferTerm args trm of Ok (t,ty) -> if eqType ty val then return (t,True) else do - putStrLn $ "term: " ++ printTree trm ++ - "\nexpected type: " ++ printTree val ++ - "\ninferred type: " ++ printTree ty + putStrLn $ "term: " ++ prt trm ++ + "\nexpected type: " ++ prt val ++ + "\ninferred type: " ++ prt ty return (t,False) Bad s -> do putStrLn s return (trm,False) -eqType :: Tpe -> Tpe -> Bool +eqType :: CType -> CType -> Bool eqType inf exp = case (inf,exp) of (C k, C n) -> k <= n -- only run-time corr. (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts] @@ -104,21 +103,21 @@ eqType inf exp = case (inf,exp) of -- should be in a generic module, but not in the run-time DataGFCC -type Tpe = Term -type LinType = ([Tpe],Tpe) +type CType = Term +type LinType = ([CType],CType) -tuple :: [Tpe] -> Tpe +tuple :: [CType] -> CType tuple = R -ints :: Int -> Tpe +ints :: Int -> CType ints = C -str :: Tpe +str :: CType str = S [] lintype :: GFCC -> CId -> CId -> LinType -lintype gfcc lang fun = case lookType gfcc fun of - Typ cs c -> (map linc cs, linc c) +lintype gfcc lang fun = case catSkeleton (lookType gfcc fun) of + (cs,c) -> (map linc cs, linc c) ---- HOAS where linc = lookLincat gfcc lang diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs index a06c9cae1..aac35857b 100644 --- a/src/GF/GFCC/DataGFCC.hs +++ b/src/GF/GFCC/DataGFCC.hs @@ -52,7 +52,7 @@ mkGFCC (Grm a cs ab@(Abs afls fs cts) ccs) = GFCC { lcats = [(c,hyps) | Cat c hyps <- cts] cats = fromAscList lcats catfuns = fromAscList - [(cat,[f | (f, (Typ _ c,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] in Abstr aflags funs cats catfuns, concretes = fromAscList (lmap mkCnc ccs) } diff --git a/src/GF/GFCC/Generate.hs b/src/GF/GFCC/Generate.hs index 09212976a..8baaf12d7 100644 --- a/src/GF/GFCC/Generate.hs +++ b/src/GF/GFCC/Generate.hs @@ -11,16 +11,16 @@ import System.Random generate :: GFCC -> CId -> [Exp] generate gfcc cat = concatMap (\i -> gener i cat) [0..] where - gener 0 c = [tree (AC f) [] | (f, Typ [] _) <- fns c] + gener 0 c = [tree (AC f) [] | (f, ([],_)) <- fns c] gener i c = [ tr | - (f, Typ cs _) <- fns c, + (f, (cs,_)) <- fns c, let alts = map (gener (i-1)) cs, ts <- combinations alts, let tr = tree (AC f) ts, depth tr >= i ] - fns = functionsToCat gfcc + fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat gfcc c] -- generate an infinite list of trees randomly @@ -55,7 +55,7 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0) gen) cat where in (t:ts, k + ks) _ -> ([],0) - fns cat = [(f,cs) | (f, Typ cs _) <- functionsToCat gfcc cat] + fns cat = [(f,(fst (catSkeleton ty))) | (f,ty) <- functionsToCat gfcc cat] {- diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs index cfb257ab8..a23c4c021 100644 --- a/src/GF/GFCC/Macros.hs +++ b/src/GF/GFCC/Macros.hs @@ -38,6 +38,20 @@ depth tr = case tr of tree :: Atom -> [Exp] -> Exp tree = DTr [] +cftype :: [CId] -> CId -> Type +cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val [] + +catSkeleton :: Type -> ([CId],CId) +catSkeleton ty = case ty of + DTyp hyps val _ -> ([valCat ty | Hyp _ ty <- hyps],val) + +valCat :: Type -> CId +valCat ty = case ty of + DTyp _ val _ -> val + +wildCId :: CId +wildCId = CId "_" + exp0 :: Exp exp0 = Tr (AM 0) []