diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 8d7021df0..0e0568281 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index fef72fc28..40e9d2962 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -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) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 2029a3c7b..dd344d31d 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -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 diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs index 2cf9d663b..8b2e2c312 100644 --- a/src/compiler/GF/Compile/Tags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -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 ++ diff --git a/src/compiler/GF/Compile/TypeCheck/Primitives.hs b/src/compiler/GF/Compile/TypeCheck/Primitives.hs index e45956cec..ddc5982cf 100644 --- a/src/compiler/GF/Compile/TypeCheck/Primitives.hs +++ b/src/compiler/GF/Compile/TypeCheck/Primitives.hs @@ -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) diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 6e40970dd..ab0796020 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -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) -> diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs index 7a86b77a2..239a66db1 100644 --- a/src/compiler/GF/Grammar/Analyse.hs +++ b/src/compiler/GF/Grammar/Analyse.hs @@ -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] diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 9291401ae..ded866b62 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -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)] diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 687840e24..0d35fd4d0 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -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))] diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 00b5dbb20..9ddaac6d1 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 64a659bb1..b8764fafa 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -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 diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index cafda3aff..262318178 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -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 <>