dependency labels are now stored in the PGF

This commit is contained in:
Krasimir Angelov
2018-11-14 17:29:44 +01:00
parent fd2aa96e65
commit b0cf72f0ec
25 changed files with 254 additions and 69 deletions

View File

@@ -76,9 +76,27 @@ typedef GuSeq PgfEquations;
typedef void *PgfFunction;
typedef enum {
PGF_DEP_PRAGMA_HEAD,
PGF_DEP_PRAGMA_MOD,
PGF_DEP_PRAGMA_REL,
PGF_DEP_PRAGMA_SKIP,
PGF_DEP_PRAGMA_ANCH,
PGF_DEP_PRAGMA_TAGS
} PgfDepPragmaTag;
typedef struct {
PgfDepPragmaTag tag;
size_t index;
GuString label;
} PgfDepPragma;
typedef GuSeq PgfDepPragmas;
typedef struct {
PgfCId name;
PgfType* type;
PgfDepPragmas* pragmas;
int arity;
PgfEquations* defns; // maybe null
PgfExprProb ep;

View File

@@ -60,7 +60,44 @@ pgf_print_absfuns(PgfAbsFuns* absfuns, GuOut *out, GuExn* err)
pgf_print_cid(absfun->name, out, err);
gu_puts(" : ", out, err);
pgf_print_type(absfun->type, NULL, 0, out, err);
gu_printf(out, err, " ; -- %f\n", absfun->ep.prob);
gu_printf(out, err, " ; -- %f ", absfun->ep.prob);
size_t n_pragmas = gu_seq_length(absfun->pragmas);
for (size_t i = 0; i < n_pragmas; i++) {
PgfDepPragma* pragma =
gu_seq_index(absfun->pragmas, PgfDepPragma, i);
switch (pragma->tag) {
case PGF_DEP_PRAGMA_HEAD:
gu_puts("head",out,err);
if (pragma->index > 0)
gu_printf(out,err,":%d", pragma->index);
if (pragma->label != NULL && *pragma->label != 0)
gu_printf(out,err,":%s", pragma->label);
break;
case PGF_DEP_PRAGMA_MOD:
gu_puts(pragma->label, out,err);
if (pragma->index > 0)
gu_printf(out,err,":%d", pragma->index);
break;
case PGF_DEP_PRAGMA_REL:
gu_puts("rel",out,err);
if (pragma->index > 0)
gu_printf(out,err,":%d", pragma->index);
break;
case PGF_DEP_PRAGMA_SKIP:
gu_puts("_",out,err);
break;
case PGF_DEP_PRAGMA_ANCH:
gu_puts("anchor",out,err);
break;
default:
gu_impossible();
}
gu_putc(' ', out, err);
}
gu_putc('\n', out, err);
}
}
static void

View File

@@ -407,6 +407,45 @@ pgf_read_patt(PgfReader* rdr)
return patt;
}
static PgfDepPragmas*
pgf_read_deppragmas(PgfReader* rdr)
{
size_t n_pragmas = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, NULL);
GuSeq* pragmas = gu_new_seq(PgfDepPragma, n_pragmas, rdr->opool);
for (size_t i = 0; i < n_pragmas; i++) {
PgfDepPragma* pragma = gu_seq_index(pragmas, PgfDepPragma, i);
pragma->tag = pgf_read_tag(rdr);
gu_return_on_exn(rdr->err, NULL);
switch (pragma->tag) {
case PGF_DEP_PRAGMA_HEAD:
pragma->index = pgf_read_int(rdr);
pragma->label = pgf_read_string(rdr);
break;
case PGF_DEP_PRAGMA_MOD:
pragma->index = pgf_read_int(rdr);
pragma->label = pgf_read_string(rdr);
break;
case PGF_DEP_PRAGMA_REL:
pragma->index = pgf_read_int(rdr);
pragma->label = NULL;
break;
case PGF_DEP_PRAGMA_SKIP:
pragma->index = 0;
pragma->label = NULL;
break;
case PGF_DEP_PRAGMA_ANCH:
pragma->index = 0;
pragma->label = NULL;
break;
default:
pgf_read_tag_error(rdr);
}
}
return pragmas;
}
static PgfAbsFun*
pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* absfun)
{
@@ -426,6 +465,9 @@ pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* absfun)
absfun->type = pgf_read_type_(rdr);
gu_return_on_exn(rdr->err, NULL);
absfun->pragmas = pgf_read_deppragmas(rdr);
gu_return_on_exn(rdr->err, NULL);
absfun->arity = pgf_read_int(rdr);
uint8_t tag = pgf_read_tag(rdr);

View File

@@ -311,6 +311,32 @@ pgf_write_absfun(PgfAbsFun* absfun, PgfWriter* wtr)
pgf_write_type_(absfun->type, wtr);
gu_return_on_exn(wtr->err, );
size_t n_pragmas = gu_seq_length(absfun->pragmas);
for (size_t i = 0; i < n_pragmas; i++) {
PgfDepPragma* pragma =
gu_seq_index(absfun->pragmas, PgfDepPragma, i);
pgf_write_tag(pragma->tag, wtr);
switch (pragma->tag) {
case PGF_DEP_PRAGMA_HEAD:
pgf_write_int(pragma->index, wtr);
pgf_write_string(pragma->label, wtr);
break;
case PGF_DEP_PRAGMA_MOD:
pgf_write_int(pragma->index, wtr);
pgf_write_string(pragma->label, wtr);
break;
case PGF_DEP_PRAGMA_REL:
pgf_write_int(pragma->index, wtr);
break;
case PGF_DEP_PRAGMA_SKIP:
case PGF_DEP_PRAGMA_ANCH:
break;
default:
gu_impossible();
}
}
pgf_write_int(absfun->arity, wtr);

View File

@@ -335,8 +335,8 @@ functionsByCat pgf cat =
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_,_) -> Just ty
Nothing -> Nothing
Just (ty,_,_,_,_) -> Just ty
Nothing -> Nothing
-- | Converts an expression to normal form
compute :: PGF -> Expr -> Expr
@@ -363,20 +363,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse pgf id = fmap (\def -> (def,producers,consumers)) definition
where
definition = case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
Just (ty,_,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
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)
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
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
accum f (ty,_,_,_) (plist,clist) =
accum f (ty,_,_,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist
!clist' = if id `elem` cs then f : clist else clist
in (plist',clist')

View File

@@ -47,13 +47,13 @@ instance Binary CId where
instance Binary Abstr where
put abs = do put (aflags abs)
put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
put (Map.map (\(ty,ps,arity,mb_eq,prob) -> (ty,ps,arity,fmap fst mb_eq,prob)) (funs abs))
put (cats abs)
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
, funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
, funs=Map.map (\(ty,ps,arity,mb_eq,prob) -> (ty,ps,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
, cats=cats
})
@@ -199,6 +199,26 @@ instance Binary BindType where
1 -> return Implicit
_ -> decodingError
instance Binary DepPragma where
put (Head index lbl) = putWord8 0 >> put index >> put lbl
put (Mod index lbl) = putWord8 1 >> put index >> put lbl
put (Rel index) = putWord8 2 >> put index
put Skip = putWord8 3
put Anch = putWord8 4
get = do
tag <- getWord8
case tag of
0 -> do index <- get
lbl <- get
return (Head index lbl)
1 -> do index <- get
lbl <- get
return (Mod index lbl)
2 -> do index <- get
return (Rel index)
3 -> return Skip
4 -> return Anch
instance Binary CncFun where
put (CncFun fun lins) = put fun >> putArray lins
get = liftM2 CncFun get getArray

View File

@@ -28,7 +28,7 @@ data PGF = PGF {
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double),-- ^ type, arrity and definition of function + probability
funs :: Map.Map CId (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double), -- ^ type, pragmas, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category
-- 2. functions of a category. The functions are stored
-- in decreasing probability order.
@@ -105,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.

View File

@@ -1,4 +1,4 @@
module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..),
module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..), DepPragma(..),
readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
mkAbs, unAbs,
@@ -77,6 +77,14 @@ data Equation =
Equ [Patt] Expr
deriving Show
data DepPragma
= Head Int String
| Mod Int String
| Rel Int
| Skip
| Anch
-- | parses 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of
@@ -319,15 +327,15 @@ data Value
| VClosure Env Expr
| VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables
type Sig = ( Map.Map CId (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double) -- 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 (_,_,a,meqs,_) -> case meqs of
Just (eqs,_)
-> if a == 0
then case eqs of
@@ -349,12 +357,12 @@ 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
Nothing -> error ("unknown function "++showCId f)
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
(Implicit,VImplArg v) -> apply sig (v:env) e vs

View File

@@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
cat = case pfuns of
[] -> wildCId
(pfun:_) -> case Map.lookup pfun (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),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

View File

@@ -109,7 +109,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] 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) =

View File

@@ -22,13 +22,13 @@ 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
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
@@ -61,7 +61,7 @@ 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 ([],[],0) cat $ cats $ abstract pgf

View File

@@ -39,7 +39,7 @@ getAbstract =
funs <- getMap getCId getFun
cats <- getMap getCId getCat
return (Abstr{ aflags=aflags
, funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
, funs=fmap (\(w,x,y,z) -> (w,[],x,fmap (flip (,) []) y,z)) funs
, cats=fmap (\(x,y) -> (x,y,0)) cats
})
getFun :: Get (Type,Int,Maybe [Equation],Double)

View File

@@ -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

View File

@@ -31,15 +31,15 @@ ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+>
ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc
ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
ppFun f (t,_,Just (eqs,code),_) = 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]) $$
ppCode 0 code
ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppFun :: CId -> (Type,[DepPragma],Int,Maybe ([Equation],[[Instr]]),Double) -> Doc
ppFun f (t,_,_,Just (eqs,code),_) = 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]) $$
ppCode 0 code
ppFun f (t,_,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =

View File

@@ -76,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,p) -> (p,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,_) p -> (ty,a,df, p)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
funs = mapUnionWith (\(ty,ps,a,df,_) p -> (ty,ps,a,df, p)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -95,8 +95,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
@@ -113,7 +113,7 @@ mkProbDefs pgf =
hyps0
[1..]
fns = [(f,ty) | (_,f) <- fs,
let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))]
let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))]
]
((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) ->
let st0 = (1,Map.empty)
@@ -263,7 +263,7 @@ computeConstrs pgf st fns =
where
addArgs (cn,fns) = addArg (length args) cn [] fns
where
Just (DTyp args _ _es,_,_,_) = Map.lookup cn (funs (abstract pgf))
Just (DTyp args _ _es,_,_,_,_) = Map.lookup cn (funs (abstract pgf))
addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)]
addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns]

View File

@@ -38,7 +38,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
@@ -51,8 +51,8 @@ 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
in (x,c)) fset
let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
in (x,c)) fset
in Map.fromList $ Set.toList fsetTypes
{-
@@ -67,7 +67,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

View File

@@ -135,8 +135,8 @@ lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
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)