msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

dependency labels are now stored in the PGF

Browse Source
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
Download Patch File Download Diff File Expand all files Collapse all files

6
src/compiler/GF/Command/Commands.hs
View File

@@ -723,7 +723,7 @@ pgfCommands = Map.fromList [
case toExprs arg of
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just fd -> do putStrLn $ render (ppFun id fd)
let (_,_,_,prob) = fd
let (_,_,_,_,prob) = fd
putStrLn ("Probability: "++show prob)
return void
Nothing -> case Map.lookup id (cats (abstract pgf)) of
@@ -732,7 +732,7 @@ pgfCommands = Map.fromList [
if null (functionsToCat pgf id)
then empty
else ' ' $$
vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
vcat [ppFun fid (ty,[],0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
' ')
let (_,_,prob) = cd
putStrLn ("Probability: "++show prob)
@@ -909,7 +909,7 @@ pgfCommands = Map.fromList [
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
funsigs pgf = [(f,ty) | (f,(ty,_,_,_,_)) <- Map.assocs (funs (abstract pgf))]
showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
morphos (Env pgf mos) opts s =

2
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -35,7 +35,7 @@ cf2abstr cfg = Abstr aflags afuns acats
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
[(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), [], 0, Nothing, 0))
| rule <- allRules cfg]
cat2id = mkCId . fst

38
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -6,7 +6,7 @@ import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF(CId,mkCId,utf8CId)
import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
import PGF.Internal(fidInt,fidFloat,fidString,fidVar,DepPragma(..))
import PGF.Internal(updateProductionIndices)
import qualified PGF.Internal as C
import GF.Grammar.Predef
@@ -22,6 +22,7 @@ import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
@@ -29,13 +30,16 @@ import Data.Array.IArray
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE C.PGF
mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am
depconf <- case flag optLabelsFile opts of
Nothing -> return Map.empty
Just fpath -> readDepConfig fpath
(an,abs) <- mkAbstr am depconf
cncs <- mapM mkConcr (allConcretes gr am)
return $ updateProductionIndices (C.PGF Map.empty an abs (Map.fromList cncs))
where
cenv = resourceValues opts gr
mkAbstr am = return (mi2i am, C.Abstr flags funs cats)
mkAbstr am depconf = return (mi2i am, C.Abstr flags funs cats)
where
aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -45,7 +49,7 @@ mkCanon2pgf opts gr am = do
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) |
funs = Map.fromList [(i2i f, (mkType [] ty, fromMaybe [] (Map.lookup (i2i f) depconf), arity, mkDef gr arity mdef, 0)) |
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
let arity = mkArity ma mdef ty]
@@ -320,3 +324,29 @@ genPrintNames cdefs =
--mkArray lst = listArray (0,length lst-1) lst
mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
readDepConfig :: FilePath -> IO (Map.Map CId [DepPragma])
readDepConfig fpath =
fmap (Map.fromList . concatMap toEntry . lines) $ readFile fpath
where
toEntry l =
case words l of
[] -> []
("--":_) -> []
(fun:ws) -> [(mkCId fun,[toPragma w | w <- ws])]
toPragma "head" = Head 0 ""
toPragma ('h':'e':'a':'d':':':cs) =
case break (==':') cs of
(lbl,[] ) -> Head 0 lbl
(lbl,':':cs) -> Head (read cs) lbl
toPragma "rel" = Rel 0
toPragma ('r':'e':'l':':':cs) = Rel (read cs)
toPragma "_" = Skip
toPragma "anchor" = Anch
toPragma s =
case break (==':') s of
(lbl,[] ) -> Mod 0 lbl
(lbl,':':cs) -> Mod (read cs) lbl

2
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -273,7 +273,7 @@ hSkeleton gr =
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
jty (f,(ty,_,_,_,_)) = (f,catSkeleton ty)
{-
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =

4
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -32,8 +32,8 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
absdef2js :: (CId,(Type,[DepPragma],Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
absdef2js (f,(typ,_,_,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])

4
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -54,11 +54,11 @@ plAbstract name abs
let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
(fun, (typ, _, _, _, _)) <- Map.assocs (funs abs),
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] |
(fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
(fun, (_, _, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
)
where plType cat args = plTerm (plp cat) (map plp args)

4
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -40,8 +40,8 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
abs = abstract pgf
cncs = concretes pgf
pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
pyAbsdef :: (Type, [DepPragma], Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ
pyLiteral :: Literal -> String

8
src/compiler/GF/Infra/Option.hs
View File

@@ -157,6 +157,7 @@ data Flags = Flags {
optDocumentRoot :: Maybe FilePath, -- For --server mode
optRecomp :: Recomp,
optProbsFile :: Maybe FilePath,
optLabelsFile :: Maybe FilePath,
optRetainResource :: Bool,
optName :: Maybe String,
optPreprocessors :: [String],
@@ -268,6 +269,7 @@ defaultFlags = Flags {
optDocumentRoot = Nothing,
optRecomp = RecompIfNewer,
optProbsFile = Nothing,
optLabelsFile = Nothing,
optRetainResource = False,
optName = Nothing,
@@ -349,8 +351,9 @@ optDescr =
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
"Never recompile from source, if there is already .gfo file.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
Option ['n'] ["name"] (ReqArg name "NAME")
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from a file.",
Option [] ["depconf"] (ReqArg labelsFile "file.labels") "Read a configuration for generation of syntactic dependency graphs from a file.",
Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]),
@@ -428,6 +431,7 @@ optDescr =
gfDocuRoot x = set $ \o -> o { optDocumentRoot = Just x }
recomp x = set $ \o -> o { optRecomp = x }
probsFile x = set $ \o -> o { optProbsFile = Just x }
labelsFile x = set $ \o -> o { optLabelsFile = Just x }
name x = set $ \o -> o { optName = Just x }
addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }

18
src/runtime/c/pgf/data.h
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;

39
src/runtime/c/pgf/printer.c
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

42
src/runtime/c/pgf/reader.c
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);

26
src/runtime/c/pgf/writer.c
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);

10
src/runtime/haskell/PGF.hs
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')

24
src/runtime/haskell/PGF/Binary.hs
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

6
src/runtime/haskell/PGF/Data.hs
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.

28
src/runtime/haskell/PGF/Expr.hs
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

2
src/runtime/haskell/PGF/Forest.hs
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)

2
src/runtime/haskell/PGF/Linearize.hs
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) =

8
src/runtime/haskell/PGF/Macros.hs
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

2
src/runtime/haskell/PGF/OldBinary.hs
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)

2
src/runtime/haskell/PGF/Paraphrase.hs
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

18
src/runtime/haskell/PGF/Printer.hs
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 =

16
src/runtime/haskell/PGF/Probabilistic.hs
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]

8
src/runtime/haskell/PGF/SortTop.hs
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

4
src/runtime/haskell/PGF/TypeCheck.hs
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)