diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs index cc27f5c1e..b11ca146d 100644 --- a/src/GF/Canon/GFCC/CheckGFCC.hs +++ b/src/GF/Canon/GFCC/CheckGFCC.hs @@ -3,6 +3,7 @@ module GF.Canon.GFCC.CheckGFCC where import GF.Canon.GFCC.DataGFCC import GF.Canon.GFCC.AbsGFCC import GF.Canon.GFCC.PrintGFCC +import GF.Canon.GFCC.ErrM import qualified Data.Map as Map import Control.Monad @@ -20,31 +21,76 @@ checkGFCC gfcc = andMapM (checkConcrete gfcc) $ Map.assocs $ concretes gfcc checkConcrete :: GFCC -> (CId,Map.Map CId Term) -> IO Bool checkConcrete gfcc (lang,cnc) = - labelBoolIO (printTree lang) $ andMapM (checkLin gfcc lang) $ linRules cnc + labelBoolIO ("happened in language " ++ printTree lang) $ + andMapM (checkLin gfcc lang) $ linRules cnc checkLin :: GFCC -> CId -> (CId,Term) -> IO Bool checkLin gfcc lang (f,t) = - labelBoolIO (printTree f) $ checkTerm (lintype gfcc lang f) $ inline gfcc lang t + labelBoolIO ("happened in function " ++ printTree f) $ + checkTerm (lintype gfcc lang f) $ inline gfcc lang t + +inferTerm :: [Tpe] -> Term -> Maybe 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) + 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) + ) + R ts -> do + tys <- mapM infer ts + return $ tuple tys + P t u -> do + R tys <- infer t + case u of + 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 + W s r -> infer r + _ -> error ("no type inference for " ++ printTree trm) + where + infer = inferTerm args checkTerm :: LinType -> Term -> IO Bool -checkTerm (args,val) trm = case (val,trm) of - (R tys, R trs) -> do - let (ntys,ntrs) = (length tys,length trs) - b <- checkCond - ("number of fields in " ++ prtrm ++ " does not match " ++ prval) (ntys == ntrs) - bs <- andMapM (uncurry check) (zip tys trs) - return $ b && bs - (R _, W _ r) -> check val r - _ -> return True - where - checkCond msg cond = if cond then return True else (putStrLn msg >> return False) - check ty tr = checkTerm (args,ty) tr - prtrm = printTree trm - prval = printTree val +checkTerm (args,val) trm = case inferTerm args trm of + Just 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 + return False + +eqType :: Tpe -> Tpe -> 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] + _ -> inf == exp -- should be in a generic module, but not in the run-time DataGFCC -type LinType = ([Term],Term) +type Tpe = Term +type LinType = ([Tpe],Tpe) + +tuple :: [Tpe] -> Tpe +tuple = R + +ints :: Int -> Tpe +ints = C + +str :: Tpe +str = S [] lintype :: GFCC -> CId -> CId -> LinType lintype gfcc lang fun = case lookType gfcc fun of diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index f42b48d1b..780ca3589 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -96,7 +96,8 @@ compute mcfg lang args = comp where proj r p = case (r,p) of (_, FV ts) -> FV $ Prelude.map (proj r) ts - (W s t, _) -> kks (s ++ getString (proj t p)) + (W s t, _) -> kks (s ++ getString (proj t p)) + (_,R is) -> comp $ foldl P r is _ -> comp $ getField r (getIndex p) getString t = case t of diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 2742629d5..9fc48eaea 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -65,7 +65,7 @@ mkCType :: Type -> C.Term mkCType t = case t of EInt i -> C.C $ fromInteger i -- record parameter alias - created in gfc preprocessing - RecType [(LIdent "_", i)] -> mkCType i + ----RecType [(LIdent "_", i)] -> mkCType i --- RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t) RecType rs -> C.R [mkCType t | (_, t) <- rs] Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt @@ -83,7 +83,7 @@ mkTerm tr = case tr of C.V (read (reverse (takeWhile (/='_') (reverse s)))) ---- from gf parser of gfc EInt i -> C.C $ fromInteger i -- record parameter alias - created in gfc preprocessing - R [(LIdent "_", (_,i))] -> mkTerm i + ----R [(LIdent "_", (_,i))] -> mkTerm i --- R [(LIdent "_", (_,i)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t) -- ordinary record R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] @@ -273,10 +273,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of (l,(_,t)) <- unlock rs] rs' = [(mkLab i, (Nothing, t2t t)) | (i,(l,(_,t))) <- zip [0..] (unlock rs)] - in if (any (isStr . trmAss) rs) - then R rs' + in + ----if (any (isStr . trmAss) rs) + ----then + R rs' --- else mkValCase tr - else R [(LIdent "_", (Nothing, mkValCase tr'))] + ----else R [(LIdent "_", (Nothing, mkValCase tr'))] --- else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))] P t l -> r2r tr PI t l i -> EInt $ toInteger i