GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

def and List

Browse Source
This commit is contained in:
aarne
2005-10-02 19:50:19 +00:00
parent 74e7f84e0f
commit df4027f798
5 changed files with 58 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

33
src/GF/Compile/CheckGrammar.hs
View File

@@ -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

9
src/GF/Grammar/AbsCompute.hs
View File

@@ -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)

8
src/GF/Grammar/Macros.hs
View File

@@ -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

7
src/GF/Grammar/TC.hs
View File

@@ -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, [])

27
src/GF/Source/SourceToGrammar.hs
View File

@@ -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