GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-08 02:32:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

restored lock fields with a clearer warning

Browse Source
This commit is contained in:
aarne
2006-06-18 19:23:00 +00:00
parent 7dec4c8a89
commit e4a9b92b85
2 changed files with 11 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -771,12 +771,12 @@ checkEqLType env t u trm = do
case t' == u' || alpha [] t' u' of case t' == u' || alpha [] t' u' of
True -> return t' True -> return t'
-- forgive missing lock fields by only generating a warning. -- forgive missing lock fields by only generating a warning.
--- better: use a flag to forgive (AR 31/1/2006) --- better: use a flag to forgive? (AR 31/1/2006)
_ -> case missingLock [] t' u' of _ -> case missingLock [] t' u' of
Ok lo -> do Ok lo -> do
checkWarn $ "missing lock field" +++ unwords (map prt lo) checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo)
return t' return t'
Bad s -> raise (s ++ "type of" +++ prt trm +++ Bad s -> raise (s +++ "type of" +++ prt trm +++
": expected" ++++ prt t' ++++ "inferred" ++++ prt u') ": expected" ++++ prt t' ++++ "inferred" ++++ prt u')
where where

12
src/GF/Grammar/Lookup.hs
View File

@@ -33,6 +33,10 @@ import GF.Grammar.Lockfield
import Data.List (nub) import Data.List (nub)
import Control.Monad import Control.Monad
-- whether lock fields are added in reuse
lock c = lockRecType c -- return
unlock c = unlockRecord c -- return
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
lookupResDef gr m c = look True m c where lookupResDef gr m c = look True m c where
look isTop m c = do look isTop m c = do
@@ -45,9 +49,9 @@ lookupResDef gr m c = look True m c where
ResOper _ Nope -> return (Q m c) ---- if isTop then lookExt m c ResOper _ Nope -> return (Q m c) ---- if isTop then lookExt m c
---- else prtBad "cannot find in exts" c ---- else prtBad "cannot find in exts" c
CncCat (Yes ty) _ _ -> return ty ---- lockRecType c $ ty CncCat (Yes ty) _ _ -> lock c ty
CncCat _ _ _ -> return defLinType ---- lockRecType c $ defLinType CncCat _ _ _ -> lock c defLinType
CncFun _ (Yes tr) _ -> return tr ---- unlockRecord c tr CncFun _ (Yes tr) _ -> unlock c tr
AnyInd _ n -> look False n c AnyInd _ n -> look False n c
ResParam _ -> return $ QC m c ResParam _ -> return $ QC m c
@@ -70,7 +74,7 @@ lookupResType gr m c = do
-- used in reused concrete -- used in reused concrete
CncCat _ _ _ -> return typeType CncCat _ _ _ -> return typeType
CncFun (Just (cat,(cont,val))) _ _ -> do CncFun (Just (cat,(cont,val))) _ _ -> do
val' <- return val ---- lockRecType cat val val' <- lock cat val
return $ mkProd (cont, val', []) return $ mkProd (cont, val', [])
CncFun _ _ _ -> lookFunType m m c CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c AnyInd _ n -> lookupResType gr n c