mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-26 03:08:55 -06:00
dependency labels are now stored in the PGF
This commit is contained in:
@@ -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;
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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);
|
||||
|
||||
@@ -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);
|
||||
|
||||
|
||||
@@ -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')
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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) =
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user