summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Compile/Optimize.hs5
-rw-r--r--src/GF/Grammar/Lookup.hs117
2 files changed, 40 insertions, 82 deletions
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index c4ea4ae34..eb3fc8383 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -166,7 +166,10 @@ mkLinDefault gr typ = do
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort s | s == cStr -> return $ Vr varStr
- QC q p -> lookupFirstTag gr q p
+ QC q p -> do vs <- lookupParamValues gr q p
+ case vs of
+ v:_ -> return v
+ _ -> Bad (render (text "no parameter values given to type" <+> ppIdent p))
RecType r -> do
let (ls,ts) = unzip r
ts' <- mapM mkDefField ts
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 93a3fdcd3..0cd46a9b9 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -18,18 +18,13 @@
module GF.Grammar.Lookup (
lookupIdent,
lookupIdentInfo,
- lookupIdentInfoIn,
lookupOrigInfo,
+ allOrigInfos,
lookupResDef,
- lookupResDefKind,
lookupResType,
lookupOverload,
- lookupParams,
lookupParamValues,
- lookupFirstTag,
- lookupIndexValue,
- allOrigInfos,
- allParamValues,
+ allParamValues,
lookupAbsDef,
lookupLincat,
lookupFunType,
@@ -63,47 +58,34 @@ lookupIdent c t =
lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
-lookupIdentInfoIn :: ModInfo Ident a -> Ident -> Ident -> Err a
-lookupIdentInfoIn mo m i =
- err (\s -> Bad (s +++ "in module" +++ showIdent m)) return $ lookupIdentInfo mo i
-
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
-lookupResDef gr m c = liftM fst $ lookupResDefKind gr m c
-
--- 0 = oper, 1 = lin, 2 = canonical. v > 0 means: no need to be recomputed
-lookupResDefKind :: SourceGrammar -> Ident -> Ident -> Err (Term,Int)
-lookupResDefKind gr m c
- | isPredefCat c = liftM (flip (,) 1) $ lock c defLinType
- ---- return (Q cPredefCnc c,2)
- ---- was PredefAbs till 3/9/2008, with explanation: need this in gf3 12/6/2008
- | otherwise = look True m c where
- look isTop m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfoIn mo m c
- case info of
- ResOper _ (Just t) -> return (qualifAnnot m t, 0)
- ResOper _ Nothing -> return (Q m c, 0) ---- if isTop then lookExt m c
- ---- else prtBad "cannot find in exts" c
-
- CncCat (Just ty) _ _ -> liftM (flip (,) 1) $ lock c ty
- CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
+lookupResDef gr m c
+ | isPredefCat c = lock c defLinType
+ | otherwise = look m c
+ where
+ look m c = do
+ mo <- lookupModule gr m
+ info <- lookupIdentInfo mo c
+ case info of
+ ResOper _ (Just t) -> return t
+ ResOper _ Nothing -> return (Q m c)
+ CncCat (Just ty) _ _ -> lock c ty
+ CncCat _ _ _ -> lock c defLinType
- CncFun (Just (cat,_,_)) (Just tr) _ -> liftM (flip (,) 1) $ unlock cat tr
- CncFun _ (Just tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
+ CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr
+ CncFun _ (Just tr) _ -> return tr
- AnyInd _ n -> look False n c
- ResParam _ _ -> return (QC m c,2)
- ResValue _ -> return (QC m c,2)
- _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
- lookExt m c =
- checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
+ AnyInd _ n -> look n c
+ ResParam _ _ -> return (QC m c)
+ ResValue _ -> return (QC m c)
+ _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
lookupResType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- ResOper (Just t) _ -> return $ qualifAnnot m t
+ ResOper (Just t) _ -> return t
-- used in reused concrete
CncCat _ _ _ -> return typeType
@@ -112,8 +94,8 @@ lookupResType gr m c = do
return $ mkProd cont val' []
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
- ResParam _ _ -> return $ typePType
- ResValue t -> return $ qualifAnnotPar m t
+ ResParam _ _ -> return typePType
+ ResValue t -> return t
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
where
lookFunType e m c = do
@@ -145,11 +127,18 @@ lookupOverload gr m c = do
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
lookupOrigInfo gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- AnyInd _ n -> lookupOrigInfo gr n c
- i -> return (m,i)
+ mo <- lookupModule gr m
+ info <- lookupIdentInfo mo c
+ case info of
+ AnyInd _ n -> lookupOrigInfo gr n c
+ i -> return (m,i)
+
+allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos gr m = errVal [] $ do
+ mo <- lookupModule gr m
+ return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]]
+ where
+ look = lookupOrigInfo gr m
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe [Term])
lookupParams gr = look True where
@@ -174,27 +163,6 @@ lookupParamValues gr m c = do
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC m f)) vs
-lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term
-lookupFirstTag gr m c = do
- vs <- lookupParamValues gr m c
- case vs of
- v:_ -> return v
- _ -> Bad (render (text "no parameter values given to type" <+> ppIdent c))
-
-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 $ render (text "no value for index" <+> int i <+> text "in" <+> ppTerm Unqualified 0 ty)
-
-allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
-allOrigInfos gr m = errVal [] $ do
- mo <- lookupModule gr m
- return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]]
- where
- look = lookupOrigInfo gr m
-
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -202,26 +170,13 @@ allParamValues cnc ptyp = case ptyp of
Q p c -> lookupResDef cnc p c >>= allParamValues cnc
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
- tss <- mapM allPV tys
+ tss <- mapM (allParamValues cnc) tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
where
- allPV = allParamValues cnc
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
-qualifAnnot :: Ident -> Term -> Term
-qualifAnnot _ = id
--- Using this we wouldn't have to annotate constants defined in a module itself.
--- But things are simpler if we do (cf. Zinc).
--- Change Rename.self2status to change this behaviour.
-
--- we need this for lookup in ResVal
-qualifAnnotPar m t = case t of
- Cn c -> Q m c
- Con c -> QC m c
- _ -> composSafeOp (qualifAnnotPar m) t
-
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
mo <- lookupModule gr m
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 16:12:44 +0000