summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/Compile/CheckGrammar.hs33
-rw-r--r--src/GF/Grammar/AbsCompute.hs9
-rw-r--r--src/GF/Grammar/Macros.hs8
-rw-r--r--src/GF/Grammar/TC.hs7
-rw-r--r--src/GF/Source/SourceToGrammar.hs27
5 files changed, 58 insertions, 26 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index f8a1911c9..fb42bd17e 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/06/22 08:52:02 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
--- > CVS $Revision: 1.28 $
+-- > CVS $Revision: 1.29 $
--
-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
--
@@ -93,18 +93,25 @@ checkAbsInfo st m (c,info) = do
checkContext st cont ---- also cstrs
AbsFun (Yes typ0) md -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
- mkCheck "function" $
- checkTyp st typ ++
- case md of
- Yes d -> checkEquation st (m,c) d
- _ -> []
- return $ (c,AbsFun (Yes typ) md)
+ mkCheck "type of function" $ checkTyp st typ
+ md' <- case md of
+ Yes d -> do
+ let d' = elimTables d
+ mkCheckWarn "definition of function" $ checkEquation st (m,c) d'
+ return $ Yes d'
+ _ -> return md
+ return $ (c,AbsFun (Yes typ) md')
_ -> return (c,info)
where
mkCheck cat ss = case ss of
[] -> return (c,info)
["[]"] -> return (c,info) ----
_ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
+ ---- temporary solution when tc of defs is incomplete
+ mkCheckWarn cat ss = case ss of
+ [] -> return (c,info)
+ ["[]"] -> return (c,info) ----
+ _ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info)
compAbsTyp g t = case t of
Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
Let (x,(_,a)) b -> do
@@ -117,6 +124,16 @@ checkAbsInfo st m (c,info) = do
Abs _ _ -> return t
_ -> composOp (compAbsTyp g) t
+ elimTables e = case e of
+ S t a -> elimSel (elimTables t) (elimTables a)
+ T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs]
+ _ -> composSafeOp elimTables e
+ elimPatt p = case p of
+ PR lps -> map snd lps
+ _ -> [p]
+ elimSel t a = case a of
+ R fs -> mkApp t (map (snd . snd) fs)
+ _ -> mkApp t [a]
checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
checkCompleteGrammar abs cnc = do
diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs
index 35be020fa..b2139f90a 100644
--- a/src/GF/Grammar/AbsCompute.hs
+++ b/src/GF/Grammar/AbsCompute.hs
@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/04/21 16:22:18 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
--
-- computation in abstract syntax w.r.t. explicit definitions.
--
@@ -72,12 +72,15 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
Ok (Just EData) -> Nothing -- canonical --- should always be QC
Ok md -> md
_ -> Nothing
+ Eqs _ -> return t ---- for nested fn
_ -> Nothing
beta :: [Ident] -> Exp -> Exp
beta vv c = case c of
App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
where xvv = (x,beta vv a)
+ Let (x,(_,a)) b -> beta vv $ substTerm vv [xvv] (beta (x:vv) b)
+ where xvv = (x,beta vv a)
App f a -> let (a',f') = (beta vv a, beta vv f) in
(if a'==a && f'==f then id else beta vv) $ App f' a'
Prod x a b -> Prod x (beta vv a) (beta (x:vv) b)
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 746526c85..6f0ee3335 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/06/03 21:51:58 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
--- > CVS $Revision: 1.22 $
+-- > CVS $Revision: 1.23 $
--
-- Macros for constructing and analysing source code terms.
--
@@ -655,6 +655,10 @@ composOp co trm =
i' <- changeTableType co i
return (TSh i' cc')
+ Eqs cc ->
+ do cc' <- mapPairListM (co . snd) cc
+ return (Eqs cc')
+
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs
diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs
index 5864c5af0..8cfe23408 100644
--- a/src/GF/Grammar/TC.hs
+++ b/src/GF/Grammar/TC.hs
@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/09/15 16:22:02 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
--- > CVS $Revision: 1.10 $
+-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
@@ -261,6 +261,9 @@ checkPatt th tenv exp val = do
checkExpP tenv@(k,rho,gamma) exp val = case exp of
Meta m -> return $ (AMeta m val, val, [])
Vr x -> return $ (AVr x val, val, [])
+ EInt i -> return (AInt i, valAbsInt, [])
+ K s -> return (AStr s, valAbsString, [])
+
Q m c -> do
typ <- lookupConst th (m,c)
return $ (ACn (m,c) typ, typ, [])
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index 4af60f1bf..563b9cc97 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/05/30 21:08:15 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
+-- > CVS $Revision: 1.27 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
@@ -251,15 +251,20 @@ transCatDef x = case x of
cont <- liftM concat $ mapM transDDecl ddecls
return (i, G.AbsCat (yes cont) nope)
listCat id ddecls size = do
- let li = mkListId id
- catd <- cat li ddecls
- let cd = M.mkDecl (G.Vr id)
- lc = G.Vr li
- niltyp = M.mkProdSimple (genericReplicate size cd) lc
- nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
- constyp = M.mkProdSimple [cd, M.mkDecl lc] lc
- consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
- return [catd,nilfund,consfund]
+ let
+ li = mkListId id
+ catd@(_,G.AbsCat (Yes cont0) _) <- cat li ddecls
+ let
+ cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
+ xs = map (G.Vr . fst) cont
+ cd = M.mkDecl (M.mkApp (G.Vr id) xs)
+ lc = M.mkApp (G.Vr li) xs
+ niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
+ nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
+ constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
+ consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
+ return [catd,nilfund,consfund]
+ mkId x i = if isWildIdent x then (mkIdent "x" i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:29:06 +0000