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

internal representation for param value index

Browse Source
This commit is contained in:
aarne
2006-11-14 19:13:33 +00:00
parent 7fc40d2b7a
commit 4b28aa89fa
16 changed files with 89 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
lib/resource-1.0/Makefile
View File

@@ -32,6 +32,7 @@ alltenses:
$(GFC) russian/Russian.gf
$(GFC) spanish/Spanish.gf
$(GFC) swedish/Swedish.gf
$(GFC) common/ConstructX.gf
cp -p */*.gfc */*.gfr ../alltenses
langs:
@@ -50,6 +51,7 @@ present:
$(GFCP) russian/LangRus.gf
$(GFCP) spanish/Spanish.gf
$(GFCP) swedish/Swedish.gf
$(GFCP) common/ConstructX.gf
mv */*.gfc */*.gfr ../present
mathematical:

2
lib/resource-1.0/common/ConstructX.gf
View File

@@ -1,3 +1,5 @@
--# -path=.:../abstract:prelude
resource ConstructX = open CommonX in {
oper

4
src/GF/Canon/CanonToGrammar.hs
View File

@@ -69,7 +69,9 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
AbsTrans t -> do
return $ G.AbsTrans t
ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par
ResPar par -> do
par' <- mapM redParam par
return $ G.ResParam (Yes (par',Nothing)) ---- list of values
CncCat pty ptr ppr -> do
ty' <- redCType pty

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

@@ -61,7 +61,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
MTTransfer a b -> mapMTree (checkAbsInfo gr name) js
MTResource -> mapMTree (checkResInfo gr) js
MTResource -> mapMTree (checkResInfo gr name) js
MTConcrete a -> do
checkErr $ topoSortOpers $ allOperDependencies name js
@@ -69,12 +69,12 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
js1 <- checkCompleteGrammar abs mo
mapMTree (checkCncInfo gr name (a,abs)) js1
MTInterface -> mapMTree (checkResInfo gr) js
MTInterface -> mapMTree (checkResInfo gr name) js
MTInstance a -> do
ModMod abs <- checkErr $ lookupModule gr a
-- checkCompleteInstance abs mo -- this is done in Rebuild
mapMTree (checkResInfo gr) js
mapMTree (checkResInfo gr name) js
return $ (name, ModMod (Module mt st fs me ops js')) : ms
@@ -167,8 +167,8 @@ checkCompleteGrammar abs cnc = do
-- | General Principle: only Yes-values are checked.
-- A May-value has always been checked in its origin module.
checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info)
checkResInfo gr (c,info) = do
checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
checkResInfo gr mo (c,info) = do
checkReservedId c
case info of
@@ -187,10 +187,11 @@ checkResInfo gr (c,info) = do
_ -> return (pty, pde) --- other cases are uninteresting
return (c, ResOper pty' pde')
ResParam (Yes pcs) -> chIn "parameter type" $ do
ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do
---- mapM ((mapM (computeLType gr . snd)) . snd) pcs
mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs
return (c,info)
ts <- checkErr $ lookupParamValues gr mo c
return (c,ResParam (Yes (pcs, Just ts)))
_ -> return (c,info)
where
@@ -226,7 +227,7 @@ checkCncInfo gr m (a,abs) (c,info) = do
checkPrintname gr mpr
return (c,CncCat (Yes typ') mdef' mpr)
_ -> checkResInfo gr (c,info)
_ -> checkResInfo gr m (c,info)
where
env = gr
@@ -360,12 +361,14 @@ inferLType gr trm = case trm of
QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
QC m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident) >>= comp
,
checkErr (lookupResDef gr m ident) >>= infer
,
prtFail "cannot infer type of canonical constant" trm
]
termWith trm $ checkErr (lookupResType gr m ident) >>= comp
,
checkErr (lookupResDef gr m ident) >>= infer
,
prtFail "cannot infer type of canonical constant" trm
]
Val ty i -> termWith trm $ return ty
Vr ident -> termWith trm $ checkLookup ident
@@ -384,7 +387,7 @@ inferLType gr trm = case trm of
then return val
else substituteLType [(z,a')] val
return (App f' a',ty)
_ -> prtFail ("function type expected for" +++ prt f +++ "instead of") fty
_ -> prtFail ("function type expected for"+++ prt f +++"instead of") fty
S f x -> do
(f', fty) <- infer f

7
src/GF/Compile/Evaluate.hs
View File

@@ -151,6 +151,13 @@ evalConcrete gr mo = mapMTree evaldef mo where
return d
Just d -> fterm2term d >>= comp g
App f a -> case apps t of
{- ----
(h@(QC p c),xs) -> do
xs' <- mapM (comp g) xs
case lookupValueIndex gr ty t of
Ok v -> return v
_ -> return t
-}
(h@(Q p c),xs) | p == IC "Predef" -> do
xs' <- mapM (comp g) xs
(t',b) <- stmErr $ appPredefined (foldl App h xs')

2
src/GF/Compile/GrammarToCanon.hs
View File

@@ -104,7 +104,7 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
AbsTrans t ->
returns c' $ C.AbsTrans t
ResParam (Yes ps) -> do
ResParam (Yes (ps,_)) -> do
ps' <- mapM redParam ps
returns c' $ C.ResPar ps'

2
src/GF/Compile/PrOld.hs
View File

@@ -49,7 +49,7 @@ stripInfo (c,i) = case i of
AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
ResParam (Yes ps) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps])
ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
CncCat (Yes ty) _ _ -> rc $
CncCat (Yes (stripTerm ty)) nope nope
CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope

26
src/GF/Compile/Rebuild.hs
View File

@@ -91,29 +91,3 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
then id
else (("Error: no definition given to" +++ prt f):)
{- ---- should not be needed
qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info)
qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
qualInfo i = case i of
ResOper pty pt -> ResOper (qualP pty) (qualP pt)
CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
ResParam (Yes ps) -> ResParam (yes (map qualParam ps))
ResValue pty -> ResValue (qualP pty)
_ -> i
qualP pt = case pt of
Yes t -> yes $ qual t
May m -> may $ qualId m
_ -> pt
qualId x = maybe x id $ lookup x insts
qual t = case t of
Q m c -> Q (qualId m) c
QC m c -> QC (qualId m) c
_ -> composSafeOp qual t
qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
qualLin Nothing = Nothing
-- NB constructor patterns never appear in interfaces so we need not rename them
-}

8
src/GF/Compile/Rename.hs
View File

@@ -159,8 +159,12 @@ renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
AbsTrans f -> liftM AbsTrans (rent f)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
ResValue t -> liftM ResValue (ren t)
ResParam (Yes (pp,m)) -> do
pp' <- mapM (renameParam status) pp
return $ ResParam $ Yes (pp',m)
ResValue (Yes (t,m)) -> do
t' <- rent t
return $ ResValue $ Yes (t',m)
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return info

11
src/GF/Grammar/Grammar.hs
View File

@@ -21,6 +21,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceRes,
SourceCnc,
Info(..),
PValues,
Perh,
MPr,
Type,
@@ -68,6 +69,9 @@ type SourceAbs = Module Ident Option Info
type SourceRes = Module Ident Option Info
type SourceCnc = Module Ident Option Info
-- this is created in CheckGrammar, and so are Val and PVal
type PValues = [Term]
-- | the constructors are judgements in
--
-- - abstract syntax (/ABS/)
@@ -84,8 +88,8 @@ data Info =
| AbsTrans Term -- ^ (/ABS/)
-- judgements in resource
| ResParam (Perh [Param]) -- ^ (/RES/)
| ResValue (Perh Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
| ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Perh Type) (Perh Term) -- ^ (/RES/)
-- judgements in concrete syntax
@@ -139,6 +143,7 @@ data Term =
| TSh TInfo [Cases] -- ^ table with discjunctive patters (only back end opt)
| V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
| S Term Term -- ^ selection: @t ! p@
| Val Type Int -- ^ parameter value number: @T # i#
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
@@ -173,6 +178,8 @@ data Patt =
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern
| PVal Type Int -- ^ parameter value number: @T # i#
| PAs Ident Patt -- ^ as-pattern: x@p
-- regular expression patterns

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

@@ -21,6 +21,8 @@ module GF.Grammar.Lookup (
lookupParams,
lookupParamValues,
lookupFirstTag,
lookupValueIndex,
lookupIndexValue,
allParamValues,
lookupAbsDef,
lookupLincat,
@@ -87,7 +89,7 @@ lookupResType gr m c = do
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes t) -> return $ qualifAnnotPar m t
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
where
@@ -104,7 +106,7 @@ lookupResType gr m c = do
_ -> prtBad "cannot find type of reused function" c
lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param]
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
lookupParams gr = look True where
look isTop m c = do
mi <- lookupModule gr m
@@ -112,9 +114,8 @@ lookupParams gr = look True where
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResParam (Yes ps) -> return ps
---- ResParam Nope -> if isTop then lookExt m c
---- else prtBad "cannot find params in exts" c
ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
@@ -123,8 +124,10 @@ lookupParams gr = look True where
lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
lookupParamValues gr m c = do
ps <- lookupParams gr m c
liftM concat $ mapM mkPar ps
(ps,mpv) <- lookupParams gr m c
case mpv of
Just ts -> return ts
_ -> liftM concat $ mapM mkPar ps
where
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co
@@ -137,6 +140,20 @@ lookupFirstTag gr m c = do
v:_ -> return v
_ -> prtBad "no parameter values given to type" c
lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
lookupValueIndex gr ty tr = do
ts <- allParamValues gr ty
case lookup tr $ zip ts [0..] of
Just i -> return $ Val ty i
_ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
lookupIndexValue gr ty i = do
ts <- allParamValues gr ty
if i < length ts
then return $ ts !! i
else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->

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

@@ -496,6 +496,7 @@ linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s"
term2patt :: Term -> Err Patt
term2patt trm = case termForm trm of
Ok ([], Vr x, []) -> return (PV x)
Ok ([], Val ty x, []) -> return (PVal ty x)
Ok ([], Con c, aa) -> do
aa' <- mapM term2patt aa
return (PC c aa')
@@ -535,7 +536,8 @@ term2patt trm = case termForm trm of
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr wildIdent --- not parsable, should not occur
PW -> Vr wildIdent --- not parsable, should not occur
PVal t i -> Val t i
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
@@ -694,6 +696,10 @@ composOp co trm =
vs' <- mapM co vs
return (V ty' vs')
Val ty i ->
do ty' <- co ty
return (Val ty' i)
Let (x,(mt,a)) b ->
do a' <- co a
mt' <- case mt of

3
src/GF/Grammar/PatternMatch.hs
View File

@@ -56,6 +56,9 @@ tryMatch (p,t) = do
where
trym p t' =
case (p,t') of
(PVal _ i, (_,Val _ j,_))
| i == j -> return []
| otherwise -> Bad $ "no match of values"
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
(PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard
(PV x, _) | isInConstantForm t -> return [(x,t)]

2
src/GF/Source/GrammarToSource.hs
View File

@@ -90,7 +90,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
Yes ps -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
May b -> P.ParDefIndir i' $ tri b
_ -> P.ParDefAbs i']]

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

@@ -293,8 +293,9 @@ transResDef x = case x of
pardefs' <- mapM transParDef pardefs
returnl $ [(p, G.ResParam (if null pars
then nope -- abstract param type
else (yes pars))) | (p,pars) <- pardefs']
++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) |
else (yes (pars,Nothing))))
| (p,pars) <- pardefs']
++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) |
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs

4
src/GF/UseGrammar/Information.hs
View File

@@ -129,10 +129,10 @@ getInformation opts st c = allChecks $ [
rs <- return []
returnm i $ IFunCnc i tr rs tr ---
ResOper (Yes ty) (Yes tr) -> returnm i $ IOper i ty tr
ResParam (Yes ps) -> do
ResParam (Yes (ps,_)) -> do
ts <- allParamValues src (QC i c)
returnm i $ IParam i ps ts
ResValue (Yes ty) -> returnm i $ IValue i ty ---
ResValue (Yes (ty,_)) -> returnm i $ IValue i ty ---
_ -> prtBad "nothing available for" i
lookInCan (i,m) = do