summaryrefslogtreecommitdiff
path: root/src/runtime/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell')
-rw-r--r--src/runtime/haskell/PGF.hs12
-rw-r--r--src/runtime/haskell/PGF/Binary.hs4
-rw-r--r--src/runtime/haskell/PGF/Data.hs8
-rw-r--r--src/runtime/haskell/PGF/Macros.hs4
-rw-r--r--src/runtime/haskell/PGF/Printer.hs4
-rw-r--r--src/runtime/haskell/PGF/Probabilistic.hs25
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs8
7 files changed, 35 insertions, 30 deletions
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index e7e5c53c5..0e3c79f40 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -292,8 +292,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
categoryContext pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (hypos,_,_) -> Just hypos
- Nothing -> Nothing
+ Just (hypos,_,_,_) -> Just hypos
+ Nothing -> Nothing
startCat pgf = DTyp [] (lookStartCat pgf) []
@@ -301,8 +301,8 @@ functions pgf = Map.keys (funs (abstract pgf))
functionsByCat pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
- Just (_,fns,_) -> map snd fns
- Nothing -> []
+ Just (_,fns,_,_) -> map snd fns
+ Nothing -> []
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
@@ -325,8 +325,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 202939f04..2debcf12d 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -40,13 +40,13 @@ instance Binary CId where
instance Binary Abstr where
put abs = put (aflags abs,
fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs),
- fmap (\(x,y,_) -> (x,y)) (cats abs))
+ fmap (\(x,y,z,_) -> (x,y,z)) (cats abs))
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
, funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
- , cats=fmap (\(x,y) -> (x,y,0)) cats
+ , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats
, code=BS.empty
})
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index e37b243d0..f5797739f 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -29,10 +29,10 @@ data PGF = PGF {
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
- cats :: Map.Map CId ([Hypo],[(Double, CId)],BCAddr), -- ^ 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.
+ cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category
+ -- 2. functions of a category. The functions are stored
+ -- in decreasing probability order.
+ -- 3. probability
code :: BS.ByteString
}
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 830a16674..ce75b1c91 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -67,7 +67,7 @@ functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
[(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
- (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
+ (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf
-- | List of functions that lack linearizations in the given language.
missingLins :: PGF -> Language -> [CId]
@@ -82,7 +82,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
- cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr)
+ cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 66d8530f0..d3a5ea1d9 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -26,8 +26,8 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
ppFlag :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
-ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc
-ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc
+ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index 7f980254b..095ade022 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/src/runtime/haskell/PGF/Probabilistic.hs
@@ -24,13 +24,14 @@ import Data.Maybe (fromMaybe) --, fromJust
-- the probabilities for the different functions in a grammar.
data Probabilities = Probs {
funProbs :: Map.Map CId Double,
- catProbs :: Map.Map CId [(Double, CId)]
+ catProbs :: Map.Map CId (Double, [(Double, CId)])
}
-- | Renders the probability structure as string
showProbabilities :: Probabilities -> String
-showProbabilities = unlines . map pr . Map.toList . funProbs where
- pr (f,d) = showCId f ++ "\t" ++ show d
+showProbabilities = unlines . concatMap prProb . Map.toList . catProbs where
+ prProb (c,(p,fns)) = pr (p,c) : map pr fns
+ pr (p,f) = showCId f ++ "\t" ++ show p
-- | Reads the probabilities from a file.
-- This should be a text file where on every line
@@ -50,8 +51,12 @@ readProbabilitiesFromFile file pgf = do
-- for the result category.
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs =
- let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf]
- cats1 = Map.map (\(_,fs,_) -> sortBy cmpProb (fill fs)) (cats (abstract pgf))
+ let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns]
+ cats1 = Map.mapWithKey (\c (_,fns,_,_) ->
+ let p' = fromMaybe 0 (Map.lookup c probs)
+ fns' = sortBy cmpProb (fill fns)
+ in (p', fns'))
+ (cats (abstract pgf))
in Probs funs1 cats1
where
cmpProb (p1,_) (p2,_) = compare p2 p1
@@ -71,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
getProbabilities :: PGF -> Probabilities
getProbabilities pgf = Probs {
- funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)),
- catProbs = Map.map (\(_,fns,_) -> fns) (cats (abstract pgf))
+ funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)),
+ catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
- funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs),
- cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
+ funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs),
+ cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -102,7 +107,7 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
mkProbDefs pgf =
- let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)),
+ let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)),
not (elem c [cidString,cidInt,cidFloat]),
let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty))
hyps0
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 141189193..e582f97af 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -121,8 +121,8 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
lookupCatHyps :: CId -> TcM s [Hypo]
lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
- Just (hyps,_,_) -> k hyps ms
- Nothing -> h (UnknownCat cat))
+ Just (hyps,_,_,_) -> k hyps ms
+ Nothing -> h (UnknownCat cat))
lookupFunType :: CId -> TcM s Type
lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
@@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
| cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
- Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
- Nothing -> h (UnknownCat cat))
+ Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms
+ Nothing -> h (UnknownCat cat))
helper (p,fn) = do
ty <- lookupFunType fn
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 12:26:04 +0000