summaryrefslogtreecommitdiff
path: root/src/runtime/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell')
-rw-r--r--src/runtime/haskell/PGF.hs4
-rw-r--r--src/runtime/haskell/PGF/Binary.hs1
-rw-r--r--src/runtime/haskell/PGF/Data.hs10
-rw-r--r--src/runtime/haskell/PGF/Macros.hs14
-rw-r--r--src/runtime/haskell/PGF/Printer.hs4
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs4
6 files changed, 16 insertions, 21 deletions
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index d27abd76c..c16f2a88c 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -315,8 +315,8 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
Nothing -> case Map.lookup id (cats (abstract pgf)) of
- Just hyps -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
- Nothing -> Nothing
+ Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
+ Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index d03349fc7..241c9cc99 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -44,7 +44,6 @@ instance Binary Abstr where
cats <- get
return (Abstr{ aflags=aflags
, funs=funs, cats=cats
- , catfuns=Map.empty
})
instance Binary Concr where
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index fe768cd20..b604317fc 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -24,10 +24,12 @@ data PGF = PGF {
}
data Abstr = Abstr {
- aflags :: Map.Map CId Literal, -- value of a flag
- funs :: Map.Map CId (Type,Int,Maybe [Equation]), -- type, arrity and definition of function
- cats :: Map.Map CId [Hypo], -- context of a cat
- catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup)
+ aflags :: Map.Map CId Literal, -- ^ value of a flag
+ funs :: Map.Map CId (Type,Int,Maybe [Equation]), -- ^ type, arrity and definition of function
+ cats :: Map.Map CId ([Hypo],[CId]) -- ^ 1. context of a category
+ -- ^ 2. functions of a category. The order in the list is important,
+ -- this is the order in which the type singatures are given in the source.
+ -- The termination of the exhaustive generation might depend on this.
}
data Concr = Concr {
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 34f32c386..d7f242c45 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -59,7 +59,7 @@ functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
[(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
- fs = lookMap [] cat $ catfuns $ abstract pgf
+ (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf
missingLins :: PGF -> CId -> [CId]
missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -72,12 +72,11 @@ hasLin pgf lang f = Map.member f $ lproductions $ lookConcr pgf lang
restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
- funs = restrict $ funs $ abstr,
- cats = restrict $ cats $ abstr
+ funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
+ cats = Map.map (\(hyps,fs) -> (hyps,filter cond fs)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
- restrict = Map.filterWithKey (\c _ -> cond c)
abstr = abstract pgf
depth :: Expr -> Int
@@ -142,13 +141,8 @@ _B = mkCId "__gfB"
_V = mkCId "__gfV"
updateProductionIndices :: PGF -> PGF
-updateProductionIndices pgf = pgf{ abstract = updateAbstract (abstract pgf)
- , concretes = fmap updateConcrete (concretes pgf)
- }
+updateProductionIndices pgf = pgf{ concretes = fmap updateConcrete (concretes pgf) }
where
- updateAbstract abs =
- abs{catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList (funs abs), c==cat]) (cats abs)}
-
updateConcrete cnc =
let prods0 = filterProductions (productions cnc)
p_prods = parseIndex cnc prods0
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 23bdc718d..1d9928304 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -28,8 +28,8 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
ppFlag :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value ;
-ppCat :: CId -> [Hypo] -> Doc
-ppCat c hyps = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))
+ppCat :: CId -> ([Hypo],[CId]) -> Doc
+ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))
ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc
ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t $$
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 2e34bc31c..3a95fc611 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -88,8 +88,8 @@ instance Functor TcM where
lookupCatHyps :: CId -> TcM [Hypo]
lookupCatHyps cat = TcM (\abstr metaid ms -> case Map.lookup cat (cats abstr) of
- Just hyps -> Ok metaid ms hyps
- Nothing -> Fail (UnknownCat cat))
+ Just (hyps,_) -> Ok metaid ms hyps
+ Nothing -> Fail (UnknownCat cat))
lookupFunType :: CId -> TcM TType
lookupFunType fun = TcM (\abstr metaid ms -> case Map.lookup fun (funs abstr) of
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:35:02 +0000