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

compute the parameter indices

Browse Source
This commit is contained in:
krangelov
2019-09-20 09:49:46 +02:00
parent 5c5af8df79
commit e989cc69a2
12 changed files with 62 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -33,14 +33,13 @@ import qualified GF.Compile.Compute.ConcreteNew as CN
import GF.Grammar
import GF.Grammar.Lexer
import GF.Grammar.Lookup
--import GF.Grammar.Predef
--import GF.Grammar.PatternMatch
import GF.Data.Operations
import GF.Infra.CheckM
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad
import GF.Text.Pretty
@@ -260,18 +259,30 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just (L loc pcs)) _ -> do
ts <- chIn loc "parameter type" $
liftM concat $ mapM mkPar pcs
return (ResParam (Just (L loc pcs)) (Just ts))
(vs,pcs) <- chIn loc "parameter type" $
mkParams 0 [] pcs
return (ResParam (Just (L loc pcs)) (Just vs))
ResValue (L loc ty) _ ->
chIn loc "operation" $ do
let (_,Cn x) = typeFormCnc ty
is = case Map.lookup x (jments mo) of
Just (ResParam (Just (L _ pcs)) _) -> [i | (f,_,i) <- pcs, f == c]
_ -> []
case is of
[i] -> return (ResValue (L loc ty) i)
_ -> checkError (pp "Failed to find the value index for parameter" <+> pp c)
_ -> return info
where
gr = prependModule sgr (m,mo)
chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
mkParams i vs [] = return (vs,[])
mkParams i vs ((f,co,_):pcs) = do
vs0 <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
(vs,pcs) <- mkParams (i + length vs0) (vs ++ map (mkApp (QC (m,f))) vs0) pcs
return (vs,(f,co,i):pcs)
checkUniq xss = case xss of
x:y:xs

4
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -353,9 +353,9 @@ paramType gr q@(_,n) =
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
param m (n,ctx,_) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
argTypes1 (n,ctx,_) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)

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

@@ -156,9 +156,9 @@ renameInfo cwd status (m,mi) i info =
ResParam (Just pp) m -> do
pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m)
ResValue offset ty -> do
ResValue ty offset -> do
t <- renLoc (renameTerm status []) ty
return (ResValue offset ty)
return (ResValue ty offset)
CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info
@@ -186,9 +186,9 @@ renameInfo cwd status (m,mi) i info =
return (ps',t')
renParam :: Status -> Param -> Check Param
renParam env (c,co) = do
renParam env (c,co,i) = do
co' <- renameContext env co
return (c,co')
return (c,co',i)
renameTerm :: Status -> [Ident] -> Term -> Check Term
renameTerm env vars = ren vars where

2
src/compiler/GF/Compile/Tags.hs
View File

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++
maybe (list (loc "def")) mb_eqs
getLocations (ResParam mb_params _) = maybe (loc "param") mb_params
getLocations (ResValue _ mb_type) = ltype "param-value" mb_type
getLocations (ResValue mb_type _) = ltype "param-value" mb_type
getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++
maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++

8
src/compiler/GF/Compile/TypeCheck/Primitives.hs
View File

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
typPredefined f = case Map.lookup f primitives of
Just (ResOper (Just (L _ ty)) _) -> Just ty
Just (ResParam _ _) -> Just typePType
Just (ResValue _ (L _ ty)) -> Just ty
Just (ResValue (L _ ty) _) -> Just ty
_ -> Nothing
primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType)
, (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue 0 (noLoc typePBool))
, (cPFalse , ResValue 1 (noLoc typePBool))
, (cPBool , ResParam (Just (noLoc [(cPTrue,[],0),(cPFalse,[],1)])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool) 0)
, (cPFalse , ResValue (noLoc typePBool) 1)
, (cError , fun [typeStr] typeError) -- non-can. of empty set
, (cLength , fun [typeTok] typeInt)
, (cDrop , fun [typeInt,typeTok] typeTok)

8
src/compiler/GF/Compile/Update.hs
View File

@@ -174,7 +174,7 @@ globalizeLoc fpath i =
AbsCat mc -> AbsCat (fmap gl mc)
AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
ResParam mt mv -> ResParam (fmap gl mt) mv
ResValue offset t -> ResValue offset (gl t)
ResValue t offset -> ResValue (gl t) offset
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -196,9 +196,9 @@ unifyAnyInfo m i j = case (i,j) of
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
(ResValue offset1 (L l1 t1), ResValue offset2 (L l2 t2))
| offset1 == offset2 && t1==t2 -> return (ResValue offset1 (L l1 t1))
| otherwise -> fail ""
(ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
| t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) ->

2
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -107,7 +107,7 @@ sizeInfo i = case i of
AbsFun mt mi me mb -> 1 + msize mt +
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt ->
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co,_) <- ps]
ResValue _ lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -330,7 +330,7 @@ data Info =
-- judgements in resource
| ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
| ResValue Int (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResValue (L Type) Int -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
@@ -459,7 +459,7 @@ type Case = (Patt, Term)
--type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)
type Param = (Ident, Context, Int)
type Altern = (Term, [(Term, Term)])
type Substitution = [(Ident, Term)]

22
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -23,10 +23,11 @@ module GF.Grammar.Lookup (
lookupResType,
lookupOverload,
lookupOverloadTypes,
lookupParamValues,
lookupParamValues,
allParamValues,
lookupAbsDef,
lookupLincat,
lookupParamValueIndex,
lookupAbsDef,
lookupLincat,
lookupFunType,
lookupCatContext,
allOpers, allOpersTo
@@ -99,7 +100,7 @@ lookupResType gr (m,c) = do
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue _ (L _ t)-> return t
ResValue (L _ t) _-> return t
_ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -113,8 +114,8 @@ lookupOverloadTypes gr id@(m,c) = do
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
ret $ mkProd cont val' []
ResParam _ _ -> ret typePType
ResValue _ (L _ t) -> ret t
ResParam _ _ -> ret typePType
ResValue (L _ t) _ -> ret t
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -176,6 +177,13 @@ allParamValues cnc ptyp =
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupParamValueIndex :: ErrorMonad m => Grammar -> QIdent -> m Int
lookupParamValueIndex gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResValue _ i -> return i
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter index defined")
lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c)
@@ -226,7 +234,7 @@ allOpers gr =
typesIn info = case info of
AbsFun (Just ltyp) _ _ _ -> [ltyp]
ResOper (Just ltyp) _ -> [ltyp]
ResValue _ ltyp -> [ltyp]
ResValue ltyp _ -> [ltyp]
ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs]
CncFun (Just (i,ctx,typ)) _ _ _ ->
[L NoLoc (mkProdSimple ctx (lock' i typ))]

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

@@ -22,14 +22,12 @@ import GF.Data.Operations
import GF.Data.Str
import GF.Infra.Ident
import GF.Grammar.Grammar
--import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Grammar.Printer
import Control.Monad.Identity(Identity(..))
import qualified Data.Traversable as T(mapM)
import Control.Monad (liftM, liftM2, liftM3)
--import Data.Char (isDigit)
import Data.List (sortBy,nub)
import Data.Monoid
import GF.Text.Pretty(render,(<+>),hsep,fsep)
@@ -48,7 +46,7 @@ typeForm t =
Q c -> ([],c,[])
QC c -> ([],c,[])
Sort c -> ([],(MN identW, c),[])
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
_ -> error (render ("no normal form of type" <+> show t))
typeFormCnc :: Type -> (Context, Type)
typeFormCnc t =
@@ -615,13 +613,15 @@ allDependencies ism b =
opersIn t = case t of
Q (n,c) | ism n -> [c]
QC (n,c) | ism n -> [c]
Cn c -> [c]
_ -> collectOp opersIn t
opty (Just (L _ ty)) = opersIn ty
opty _ = []
pts i = case i of
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont,_) <- ps, (_,_,t) <- cont]
ResValue pty _ -> [Just pty]
CncCat pty _ _ _ _ -> [pty]
CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual

6
src/compiler/GF/Grammar/Parser.y
View File

@@ -266,7 +266,7 @@ DataDef
ParamDef :: { [(Ident,Info)] }
ParamDef
: Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
[(f, ResValue 0 (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
[(f, ResValue (L loc (mkProdSimple co (Cn $2))) i) | L loc (f,co,i) <- $4] }
| Posn LhsIdent Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] }
@@ -301,7 +301,7 @@ ListDataConstr
ParConstr :: { L Param }
ParConstr
: Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) }
: Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3,0) }
ListLinDef :: { [(Ident,Info)] }
ListLinDef
@@ -773,7 +773,7 @@ checkInfoType mt jment@(id,info) =
CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue _ ty -> ifResource mt (locL ty)
ResValue ty _ -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
where

6
src/compiler/GF/Grammar/Printer.hs
View File

@@ -106,8 +106,8 @@ ppJudgement q (id, ResParam pparams _) =
(case pparams of
Just (L _ ps) -> '=' <+> ppParams q ps
_ -> empty) <+> ';'
ppJudgement q (id, ResValue _ pvalue) =
"-- param constructor" <+> id <+> ':' <+>
ppJudgement q (id, ResValue pvalue i) =
"-- param constructor" <+> "[index" <+> i <> "]" <+> id <+> ':' <+>
(case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> ';'
ppJudgement q (id, ResOper ptype pexp) =
@@ -322,7 +322,7 @@ ppBind (Implicit,v) = braces v
ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppParam q (id,cxt,_) = id <+> hsep (map (ppDDecl q) cxt)
ppProduction (Production fid funid args) =
ppFId fid <+> "->" <+> ppFunId funid <>