diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 72e57fcf5..43c686784 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -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 = diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index afc9de41f..e911c5658 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -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 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index eb127f7bd..9bfdcda01 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -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 diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index fc17e4e4e..c0bfda355 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -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 = diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index 0fc898aab..684c3e2a1 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -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)]) diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index 1279e3d8a..7e09b99ed 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -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) diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index f977abead..aca950122 100644 --- a/src/compiler/GF/Compile/PGFtoPython.hs +++ b/src/compiler/GF/Compile/PGFtoPython.hs @@ -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 diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 27aa1c256..f26dc50bc 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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 } diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 64009ee72..2631bc5a4 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -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; diff --git a/src/runtime/c/pgf/printer.c b/src/runtime/c/pgf/printer.c index 29f8eb29e..e339fb30f 100644 --- a/src/runtime/c/pgf/printer.c +++ b/src/runtime/c/pgf/printer.c @@ -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 diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index c97b52125..3a83be2fe 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -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); diff --git a/src/runtime/c/pgf/writer.c b/src/runtime/c/pgf/writer.c index 865d27826..166b9cdc1 100644 --- a/src/runtime/c/pgf/writer.c +++ b/src/runtime/c/pgf/writer.c @@ -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); diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 3cd417c73..5f2fe62be 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -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') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index e0e50f4be..e9215070f 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index e85ee5aa2..ba13a0692 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -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. diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index d015f18e0..b0a32dcee 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index f25bc05d7..55c0e9477 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 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) diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index 5fdb186c1..027c712ed 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -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) = diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 3fc7a5804..fd9ec3613 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -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 diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs index 6acc18895..109936719 100644 --- a/src/runtime/haskell/PGF/OldBinary.hs +++ b/src/runtime/haskell/PGF/OldBinary.hs @@ -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) diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs index 8bee81f43..12a1b5ebd 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 3501f49b0..8b0f3f481 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -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 = diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index 37db7f7ff..9f95b7206 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -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] diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs index c31b32e91..f7f889ff1 100644 --- a/src/runtime/haskell/PGF/SortTop.hs +++ b/src/runtime/haskell/PGF/SortTop.hs @@ -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 diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 5db4ef439..a95d4df79 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -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)