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

6
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,7 +351,8 @@ 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 [] ["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, ",
@@ -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

@@ -312,6 +312,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);
pgf_write_tag((absfun->defns == NULL) ? 0 : 1, wtr);

8
src/runtime/haskell/PGF.hs
View File

@@ -335,7 +335,7 @@ functionsByCat pgf cat =
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_,_) -> Just ty
Just (ty,_,_,_,_) -> Just ty
Nothing -> Nothing
-- | Converts an expression to normal form
@@ -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.

16
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,7 +327,7 @@ data Value
| VClosure Env Expr
| VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun
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]
@@ -327,7 +335,7 @@ 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,7 +357,7 @@ 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 (_,_,a,meqs,_) -> case meqs of
Just (eqs,_) -> if a <= length vs
then match sig f eqs vs
else VApp f 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) =

6
src/runtime/haskell/PGF/Macros.hs
View File

@@ -22,12 +22,12 @@ 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
Just (_,_,_,Nothing,_) -> True -- the encoding of data constrs
_ -> False
lookValCat :: Abstr -> CId -> CId
@@ -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

6
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 ';' $$
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 ';'
ppFun f (t,_,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =

10
src/runtime/haskell/PGF/Probabilistic.hs
View File

@@ -76,14 +76,14 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
getProbabilities :: PGF -> Probabilities
getProbabilities pgf = Probs {
funProbs = Map.map (\(_,_,_,p) -> p ) (funs (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),
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
@@ -95,7 +95,7 @@ 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
Just (_,_,_,_,p) -> p
Nothing -> 1
_ -> 1
@@ -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]

6
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,7 +51,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
@@ -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

2
src/runtime/haskell/PGF/TypeCheck.hs
View File

@@ -135,7 +135,7 @@ 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
Just (ty,_,_,_,_) -> k ty ms
Nothing -> h (UnknownFun fun))
typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]