From bcd830129e210e0bf9e72039ed7fcf1384b2f2c0 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 3 Oct 2007 11:49:46 +0000 Subject: [PATCH] uncurrying performed in CheckGFCC --- src/GF/Canon/GFCC/CheckGFCC.hs | 75 +++++++++++++++++++--------------- src/GF/Canon/GFCC/DataGFCC.hs | 7 ++++ src/GF/Devel/GFC.hs | 15 ++++--- 3 files changed, 55 insertions(+), 42 deletions(-) diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs index 19e816e95..a94e0e1fb 100644 --- a/src/GF/Canon/GFCC/CheckGFCC.hs +++ b/src/GF/Canon/GFCC/CheckGFCC.hs @@ -11,81 +11,88 @@ import Control.Monad andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool andMapM f xs = mapM f xs >>= return . and -labelBoolIO :: String -> IO Bool -> IO Bool +labelBoolIO :: String -> IO (x,Bool) -> IO (x,Bool) labelBoolIO msg iob = do - b <- iob - if b then return b else (putStrLn msg >> return b) + (x,b) <- iob + if b then return (x,b) else (putStrLn msg >> return (x,b)) -checkGFCC :: GFCC -> IO Bool -checkGFCC gfcc = andMapM (checkConcrete gfcc) $ Map.assocs $ concretes gfcc +checkGFCC :: GFCC -> IO (GFCC,Bool) +checkGFCC gfcc = do + (cs,bs) <- mapM (checkConcrete gfcc) + (Map.assocs (concretes gfcc)) >>= return . unzip + return (gfcc {concretes = Map.fromAscList cs}, and bs) -checkConcrete :: GFCC -> (CId,Map.Map CId Term) -> IO Bool +checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool) checkConcrete gfcc (lang,cnc) = - labelBoolIO ("happened in language " ++ printTree lang) $ - andMapM (checkLin gfcc lang) $ linRules cnc + labelBoolIO ("happened in language " ++ printTree lang) $ do + (rs,bs) <- mapM (checkLin gfcc lang) (linRules cnc) >>= return . unzip + return ((lang,Map.fromAscList rs),and bs) -checkLin :: GFCC -> CId -> (CId,Term) -> IO Bool +checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool) checkLin gfcc lang (f,t) = - labelBoolIO ("happened in function " ++ printTree f) $ - checkTerm (lintype gfcc lang f) $ inline gfcc lang t + labelBoolIO ("happened in function " ++ printTree f) $ do + (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t + return ((f,t'),b) -inferTerm :: [Tpe] -> Term -> Err Tpe +inferTerm :: [Tpe] -> Term -> Err (Term,Tpe) inferTerm args trm = case trm of - K _ -> return str - C i -> return $ ints i + K _ -> returnt str + C i -> returnt $ ints i V i -> do testErr (i < length args) ("too large index " ++ show i) - return $ args !! i + returnt $ args !! i S ts -> do - tys <- mapM infer ts + (ts',tys) <- mapM infer ts >>= return . unzip let tys' = filter (/=str) tys testErr (null tys') ("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys')) - return str + return (S ts',str) R ts -> do - tys <- mapM infer ts - return $ tuple tys + (ts',tys) <- mapM infer ts >>= return . unzip + return $ (R ts',tuple tys) P t u -> do - tt <- infer t - tu <- infer u + (t',tt) <- infer t + (u',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) ----- + R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]] + --- R [v] -> infer $ P t v + --- R (v:vs) -> infer $ P (head tys) (R vs) 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 + (returnt $ 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 + returnt typ -- table: must be same _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt - FV [] -> return str ---- + FV [] -> returnt str ---- FV (t:ts) -> do - ty <- infer t - tys <- mapM infer ts + (t',ty) <- infer t + (ts',tys) <- mapM infer ts >>= return . unzip testErr (all (==ty) tys) ("different types in variants " ++ prt trm) - return ty + return (FV (t':ts'),ty) W s r -> infer r _ -> Bad ("no type inference for " ++ prt trm) where + returnt ty = return (trm,ty) infer = inferTerm args prt = printTree -checkTerm :: LinType -> Term -> IO Bool +checkTerm :: LinType -> Term -> IO (Term,Bool) checkTerm (args,val) trm = case inferTerm args trm of - Ok ty -> if eqType ty val - then return True + 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 - return False + return (trm,False) Bad s -> do putStrLn s - return False + return (trm,False) eqType :: Tpe -> Tpe -> Bool eqType inf exp = case (inf,exp) of diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index b841a0ce3..d302f75fe 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -139,3 +139,10 @@ mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC { where mkCnc lins = fromList [(fun,lin) | Lin fun lin <- lins] ---- Asc +printGFCC :: GFCC -> String +printGFCC gfcc = printTree $ Grm + (Hdr (absname gfcc) (cncnames gfcc)) + (Abs [Fun f ty (Tr (AC f) []) | (f,ty) <- assocs (funs (abstract gfcc))]) + [Cnc lang [Lin f t | (f,t) <- assocs lins] | + (lang,lins) <- assocs (concretes gfcc)] + diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index 6d9108eea..0e3c75501 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -20,19 +20,18 @@ main = do _ | oElem (iOpt "-make") opts -> do gr <- batchCompile opts fs let name = justModuleName (last fs) - let (abs,gc) = mkCanon2gfcc opts name gr - - if oElem (iOpt "check") opts then (check gc) else return () - + let (abs,gc0) = mkCanon2gfcc opts name gr + gc <- check gc0 let target = abs ++ ".gfcc" - writeFile target (printTree gc) + writeFile target (printGFCC gc) putStrLn $ "wrote file " ++ target _ -> do mapM_ (batchCompile opts) (map return fs) putStrLn "Done." -check gc = do - let gfcc = mkGFCC gc - b <- checkGFCC gfcc +check gc0 = do + let gfcc = mkGFCC gc0 + (gc,b) <- checkGFCC gfcc putStrLn $ if b then "OK" else "Corrupted GFCC" + return gc