From 76faee5cd5605161d6b191bfe4e0640600ab4f59 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 14 Jan 2026 14:21:24 +0100 Subject: [PATCH] use the cached parameter count --- src/compiler/api/GF/Compile/GeneratePMCFG.hs | 16 +++---- src/compiler/api/GF/Grammar/Lookup.hs | 46 ++++++++++++++------ 2 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index 8bfe3ff6d..4cf1ba725 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -92,8 +92,8 @@ pmcfgForm g t ctxt ty = do where boundsOf sgr ms i = case Map.lookup (i+1) ms of - Just (Narrowing _ pty) -> case allParamValues sgr pty of - Ok ps -> length ps + Just (Narrowing _ pty) -> case countParamValues sgr pty of + Ok c -> c Bad msg -> error msg _ -> error (show (ppLVar i <+> "is not a free variable")) @@ -123,7 +123,7 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ let T _ cs = mkWildCases t' return $ T (TWild p) cs Sort s | s == cStr -> return (Vr varStr) - QC p -> case lookupParamValues gr p of + QC p -> case allParamValues gr ty of Ok [] -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) Ok (v:_) -> return v Bad msg -> fail msg @@ -176,8 +176,8 @@ type2metaTerm gr d ms s r rs (Table p q) params delta = r'-r in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params') where - count = case allParamValues gr p of - Ok ts -> length ts + count = case countParamValues gr p of + Ok c -> c Bad msg -> error msg type2metaTerm gr d ms c r rs ty@(QC q) params = let i = Map.size ms + 1 @@ -218,7 +218,7 @@ breakDown g ms c r rs v (Table p q) fn0 fn = do v0 = VS v v2 [] (c1,c2) = split c Gl gr _ = g - cnt <- fmap length $ allParamValues gr p + cnt <- countParamValues gr p (ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) -> breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn return (ms,r+(r'-r)*cnt,fn0,fn) @@ -476,8 +476,8 @@ setMeta i st = GenM $ \_ k svs ms -> k () svs (Map.insert i st ms) getCnt ty = GenM $ \(Gl gr _) k svs ms r -> - case allParamValues gr ty of - Ok ts -> k (length ts) svs ms r + case countParamValues gr ty of + Ok c -> k c svs ms r Bad msg -> checkError (pp msg) getIdxCnt q = GenM $ \(Gl gr _) k svs ms r -> diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index 6c133e085..b86596be7 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -23,8 +23,8 @@ module GF.Grammar.Lookup ( lookupResType, lookupOverload, lookupOverloadTypes, - lookupParamValues, allParamValues, + countParamValues, lookupAbsDef, lookupLincat, lookupFunType, @@ -180,32 +180,50 @@ allOrigInfos gr m = fromErr [] $ do ModInfo{jments=jments} -> return [((m,c),i) | (c,_) <- Map.toList jments, Ok (m,i) <- [lookupOrigInfo gr (m,c)]] _ -> return [] -lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term] -lookupParamValues gr c = do - (_,info) <- lookupOrigInfo gr c - case info of - ResParam _ (Just (pvs,_)) -> return pvs - _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") - allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term] -allParamValues cnc ptyp = +allParamValues gr ptyp = case ptyp of _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] - QC c -> lookupParamValues cnc c - Q c -> lookupResDef cnc c >>= allParamValues cnc + QC c -> do (_,info) <- lookupOrigInfo gr c + case info of + ResParam _ (Just (pvs,_)) -> return pvs + _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") + Q c -> lookupResDef gr c >>= allParamValues gr RecType r -> do let (ls,lls,tys) = unzip3 $ sortByLbl r - tss <- mapM (allParamValues cnc) tys + tss <- mapM (allParamValues gr) tys return [R (zipAssign ls ts) | ts <- sequence tss] Table pt vt -> do - pvs <- allParamValues cnc pt - vvs <- allParamValues cnc vt + pvs <- allParamValues gr pt + vvs <- allParamValues gr vt return [V pt ts | ts <- sequence (replicate (length pvs) vvs)] _ -> raise (render ("cannot find parameter values for" <+> ptyp)) where -- to normalize records and record types sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2) +countParamValues :: ErrorMonad m => Grammar -> Type -> m Int +countParamValues gr ptyp = + case ptyp of + _ | Just n <- isTypeInts ptyp -> return (fromIntegral n) + QC c -> do (_,info) <- lookupOrigInfo gr c + case info of + ResParam _ (Just (_,cnt)) -> return cnt + _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") + Q c -> lookupResDef gr c >>= countParamValues gr + RecType r -> do + let (ls,lls,tys) = unzip3 $ sortByLbl r + cs <- mapM (countParamValues gr) tys + return (product cs) + Table pt vt -> do + pc <- countParamValues gr pt + vc <- countParamValues gr vt + return (vc ^ pc) + _ -> raise (render ("cannot find parameter values for" <+> ptyp)) + where + -- to normalize records and record types + sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2) + 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)