summaryrefslogtreecommitdiff
path: root/src/runtime/haskell/PGF
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell/PGF')
-rw-r--r--src/runtime/haskell/PGF/Binary.hs1
-rw-r--r--src/runtime/haskell/PGF/Data.hs19
-rw-r--r--src/runtime/haskell/PGF/Expr.hs30
-rw-r--r--src/runtime/haskell/PGF/Forest.hs2
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs2
-rw-r--r--src/runtime/haskell/PGF/Macros.hs14
-rw-r--r--src/runtime/haskell/PGF/Paraphrase.hs2
-rw-r--r--src/runtime/haskell/PGF/Printer.hs22
-rw-r--r--src/runtime/haskell/PGF/Probabilistic.hs14
-rw-r--r--src/runtime/haskell/PGF/SortTop.hs6
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs12
11 files changed, 64 insertions, 60 deletions
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 22a6ef464..e96bf0ea0 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -44,6 +44,7 @@ instance Binary Abstr where
cats <- get
return (Abstr{ aflags=aflags
, funs=funs, cats=cats
+ , code=BS.empty
})
instance Binary Concr where
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index f382601a8..357dcc92e 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -9,6 +9,7 @@ import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified GF.Data.TrieMap as TMap
+import qualified Data.ByteString as BS
import Data.Array.IArray
import Data.Array.Unboxed
import Data.List
@@ -26,12 +27,13 @@ data PGF = PGF {
}
data Abstr = Abstr {
- aflags :: Map.Map CId Literal, -- ^ value of a flag
- funs :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability
- cats :: Map.Map CId ([Hypo],[(Double, 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.
+ 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.
+ code :: BS.ByteString
}
data Concr = Concr {
@@ -70,6 +72,7 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,
type Sequence = Array DotPos Symbol
type FunId = Int
type SeqId = Int
+type BCAddr = Int
data Alternative =
Alt [Token] [String]
@@ -102,8 +105,8 @@ emptyPGF = PGF {
haveSameFunsPGF :: PGF -> PGF -> Bool
haveSameFunsPGF one two =
let
- fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
- fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
+ fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
+ fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))]
in fsone == fstwo
-- | This is just a 'CId' with the language name.
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 5fbcdf120..998819687 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -318,22 +318,22 @@ data Value
| VClosure Env Expr
| VImplArg Value
-type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun
- , Int -> Maybe Expr -- lookup for metavariables
+type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun
+ , Int -> Maybe Expr -- lookup for metavariables
)
type Env = [Value]
eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_) -> case meqs of
- Just eqs -> if a == 0
- then case eqs of
- Equ [] e : _ -> eval sig [] e
- _ -> VConst f []
- else VApp f []
- Nothing -> VApp f []
- Nothing -> error ("unknown function "++showCId f)
+ Just (_,a,meqs,_,_) -> case meqs of
+ Just eqs -> if a == 0
+ then case eqs of
+ Equ [] e : _ -> eval sig [] e
+ _ -> VConst f []
+ else VApp f []
+ Nothing -> VApp f []
+ Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
eval sig env (EMeta i) = case snd sig i of
@@ -347,11 +347,11 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_) -> case meqs of
- Just eqs -> if a <= length vs
- then match sig f eqs vs
- else VApp f vs
- Nothing -> VApp f vs
+ Just (_,a,meqs,_,_) -> case meqs of
+ Just eqs -> if a <= length vs
+ then match sig f eqs vs
+ else VApp f vs
+ Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs)
apply sig env (EAbs b x e) (v:vs) = case (b,v) of
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 24bafb475..3c4272317 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
cat = case isLindefCId fun of
Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of
- Just (DTyp _ cat _,_,_,_) -> cat
+ Just (DTyp _ cat _,_,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 9181fdab2..39c59cd3f 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -98,7 +98,7 @@ linTree pgf lang e =
Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where
toApp fid (PApply funid pargs) =
- let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
+ let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))
(args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) =
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 7879004cd..88057ce45 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -21,18 +21,18 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: Abstr -> CId -> Type
lookType abs f =
case lookMap (error $ "lookType " ++ show f) f (funs abs) of
- (ty,_,_,_) -> ty
+ (ty,_,_,_,_) -> ty
lookDef :: Abstr -> CId -> Maybe [Equation]
lookDef abs f =
case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
- (_,a,eqs,_) -> eqs
+ (_,a,eqs,_,_) -> eqs
isData :: Abstr -> CId -> Bool
isData abs f =
case Map.lookup f (funs abs) of
- Just (_,_,Nothing,_) -> True -- the encoding of data constrs
- _ -> False
+ Just (_,_,Nothing,_,_) -> True -- the encoding of data constrs
+ _ -> False
lookValCat :: Abstr -> CId -> CId
lookValCat abs = valCat . lookType abs
@@ -65,9 +65,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
- [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
+ [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
- (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf
+ (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
missingLins :: PGF -> CId -> [CId]
missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -81,7 +81,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) -> (hyps,filter (cond . snd) fs)) (cats abstr)
+ cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where
diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs
index 92e3d12ce..015779ace 100644
--- a/src/runtime/haskell/PGF/Paraphrase.hs
+++ b/src/runtime/haskell/PGF/Paraphrase.hs
@@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) |
- (f,(_,_,Just eqs,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
+ (f,(_,_,Just eqs,_,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
---- cf. PGF.Tree.expr2tree
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 980b5dcdf..c0529b116 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -28,17 +28,17 @@ 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)]) -> Doc
-ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
-
-ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc
-ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
- if null eqs
- then empty
- else text "def" <+> vcat [let scope = foldl pattScope [] patts
- ds = map (ppPatt 9 scope) patts
- in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
-ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],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 ';' $$
+ if null eqs
+ then empty
+ else text "def" <+> vcat [let scope = foldl pattScope [] patts
+ ds = map (ppPatt 9 scope) patts
+ in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
+ppFun f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index ee44e73e1..bf2464b1d 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/src/runtime/haskell/PGF/Probabilistic.hs
@@ -50,7 +50,7 @@ readProbabilitiesFromFile file pgf = do
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) -> fill fs) (cats (abstract pgf))
+ cats1 = Map.map (\(_,fs,_) -> fill fs) (cats (abstract pgf))
in Probs funs1 cats1
where
fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
@@ -68,15 +68,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,_) -> fns) (cats (abstract pgf))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
- funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df,p)) (funs (abstract pgf)) (funProbs probs),
- cats = mapUnionWith (\(hypos,_) fns -> (hypos,fns)) (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) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -87,8 +87,8 @@ probTree :: PGF -> Expr -> Double
probTree pgf t = case t of
EApp f e -> probTree pgf f * probTree pgf e
EFun f -> case Map.lookup f (funs (abstract pgf)) of
- Just (_,_,_,p) -> p
- Nothing -> 1
+ Just (_,_,_,p,_) -> p
+ Nothing -> 1
_ -> 1
-- | rank from highest to lowest probability
diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs
index b5b5f4857..42b5d36d0 100644
--- a/src/runtime/haskell/PGF/SortTop.hs
+++ b/src/runtime/haskell/PGF/SortTop.hs
@@ -39,7 +39,7 @@ showInOrder abs fset remset avset =
isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
isArg abs mtypes scid cid =
let p = Map.lookup cid $ funs abs
- (ty,_,_,_) = fromJust p
+ (ty,_,_,_,_) = fromJust p
args = arguments ty
setargs = Set.fromList args
cond = Set.null $ Set.difference setargs scid
@@ -52,7 +52,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
typesInterm abs fset =
let fs = funs abs
fsetTypes = Set.map (\x ->
- let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
+ let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
in (x,c)) fset
in Map.fromList $ Set.toList fsetTypes
@@ -68,7 +68,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat
returnCat :: Abstr -> CId -> CId
returnCat abs cid =
let p = Map.lookup cid $ funs abs
- (DTyp _ c _,_,_,_) = fromJust p
+ (DTyp _ c _,_,_,_,_) = fromJust p
in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
else c
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 890e77bb4..268742b94 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -121,13 +121,13 @@ 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
- Just (ty,_,_,_) -> k ty ms
- Nothing -> h (UnknownFun fun))
+ Just (ty,_,_,_,_) -> k ty ms
+ Nothing -> h (UnknownFun fun))
typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
@@ -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 07:10:08 +0000