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

A basic infrastructure for generating Teyjus bytecode from the GF abstract syntax

Browse Source
This commit is contained in:
kr.angelov
2012-08-29 11:43:02 +00:00
parent 27196778ac
commit f8fe23fda7
23 changed files with 211 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1071,7 +1071,7 @@ allCommands env@(pgf, mos) = Map.fromList [
if null (functionsToCat pgf id)
then empty
else space $$
vcat [ppFun fid (ty,0,Just [],0) | (fid,ty) <- functionsToCat pgf id])
vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id])
return void
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
@@ -1246,7 +1246,7 @@ allCommands env@(pgf, mos) = 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 opts s =

75
src/compiler/GF/Compile/GenerateBC.hs Normal file
View File

@@ -0,0 +1,75 @@
module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Compile.Instructions
import PGF.Data
import Data.Maybe
import qualified Data.IntMap as IntMap
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BS
import Data.Binary
generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString)
generateByteCode = runGenM . mapM genFun
type BCLabel = (Int, BCAddr)
genFun (id,info@(AbsFun (Just (L _ ty)) ma pty _)) = do
l1 <- newLabel
emitLabel l1
emit Ins_fail
l2 <- newLabel
l3 <- newLabel
emit (Ins_switch_on_reg (1,addr l2,addr l3))
emitLabel l2
emit (Ins_try (1,addr l3))
emit (Ins_trust_ext (1,1))
emit (Ins_try_me_else (0,addr l1))
emitLabel l3
l4 <- newLabel
l5 <- newLabel
emit (Ins_switch_on_term (addr l4,addr l5,addr l1,addr l4))
emitLabel l4
emitLabel l5
return (id,info,addr l1)
genFun (id,info@(AbsCat (Just (L _ cont)))) = do
l1 <- newLabel
return (id,info,addr l1)
newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr ->
IntMap.IntMap BCAddr ->
[Instruction] ->
(a,IntMap.IntMap BCAddr,[Instruction])}
instance Monad GenM where
return x = GenM (\fm cm is -> (x,cm,is))
f >>= g = GenM (\fm cm is -> case unGenM f fm cm is of
(x,cm,is) -> unGenM (g x) fm cm is)
runGenM :: GenM a -> (a, BSS.ByteString)
runGenM f =
let (x, cm, is) = unGenM f cm IntMap.empty []
in (x, BSS.concat (BS.toChunks (encode (BC (reverse is)))))
emit :: Instruction -> GenM ()
emit i = GenM (\fm cm is -> ((), cm, i:is))
newLabel :: GenM BCLabel
newLabel = GenM (\fm cm is ->
let lbl = IntMap.size cm
addr = fromMaybe (error "newLabel") (IntMap.lookup lbl fm)
in ((lbl,addr), IntMap.insert lbl 0 cm, is))
emitLabel :: BCLabel -> GenM ()
emitLabel (lbl,addr) = GenM (\fm cm is ->
((), IntMap.insert lbl (length is) cm, is))
addr :: BCLabel -> BCAddr
addr (lbl,addr) = addr
data ByteCode = BC [Instruction]
instance Binary ByteCode where
put (BC is) = mapM_ putInstruction is
get = error "get ByteCode"

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

@@ -3,6 +3,7 @@ module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString)
@@ -41,26 +42,27 @@ mkCanon2pgf opts gr am = do
cncs <- mapM (mkConcr gr) (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
mkAbstr gr am = return (i2i am, D.Abstr flags funs cats bcode)
where
aflags =
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
(adefs,bcode) =
generateByteCode $
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
((m,c),AbsCat (Just (L _ cont))) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, addr)) |
((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
mkConcr gr cm = do
let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,

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

@@ -264,7 +264,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

@@ -33,8 +33,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],Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
absdef2js :: (CId,(Type,Int,Maybe [Equation],Double,BCAddr)) -> 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)])

20
src/compiler/GF/Compile/PGFtoLProlog.hs
View File

@@ -12,25 +12,25 @@ import Debug.Trace
grammar2lambdaprolog_mod pgf = render $
text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$
vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)),
vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)),
let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]]
where
ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_,_)) <- fns] $$
space $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_)) <- fns] $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_,_)) <- fns] $$
space
grammar2lambdaprolog_sig pgf = render $
text "sig" <+> ppCId (absname pgf) <> char '.' $$
space $$
vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
space $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_,_)) <- Map.toList (funs (abstract pgf))] $$
space $$
vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))]
vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_,_)) <- Map.toList (funs (abstract pgf))]
ppCat :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
@@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args =
in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of
Just (_,_,Just _,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
Just (_,_,Just _,_,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args =
(goals,i,foldl EApp (EVar j) args)

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

@@ -49,16 +49,16 @@ plAbstract name abs
(f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] |
(cat, (hypos, _)) <- Map.assocs (cats abs),
(cat, (hypos, _, _)) <- Map.assocs (cats abs),
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
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], Double) -> String
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
pyAbsdef :: (Type, Int, Maybe [Equation], Double, BCAddr) -> String
pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ
pyLiteral :: Literal -> String

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

@@ -89,6 +89,7 @@ data OutputFormat = FmtPGFPretty
| FmtHaskell
| FmtProlog
| FmtLambdaProlog
| FmtByteCode
| FmtBNF
| FmtEBNF
| FmtRegular
@@ -436,6 +437,7 @@ outputFormatsExpl =
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("prolog", FmtProlog),"Prolog (whole grammar)"),
(("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
(("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"),
(("regular", FmtRegular),"* regular grammar"),

2
src/compiler/GF/Speech/VoiceXML.hs
View File

@@ -39,7 +39,7 @@ type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs])
| (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
| (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))]
--
-- * Questions to ask

28
src/compiler/GFC.hs
View File

@@ -18,6 +18,9 @@ import GF.Data.ErrM
import Data.Maybe
import Data.Binary
import qualified Data.Map as Map
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Char8 as BS
import System.FilePath
import System.IO
@@ -48,6 +51,7 @@ compileSourceFiles opts fs =
then return ()
else do pgf <- link opts (identC (BS.pack cnc)) gr
writePGF opts pgf
writeByteCode opts pgf
writeOutputs opts pgf
compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -78,9 +82,31 @@ unionPGFFiles opts fs =
writeOutputs :: Options -> PGF -> IOE ()
writeOutputs opts pgf = do
sequence_ [writeOutput opts name str
| fmt <- flag optOutputFormats opts,
| fmt <- flag optOutputFormats opts,
fmt /= FmtByteCode,
(name,str) <- exportPGF opts fmt pgf]
writeByteCode :: Options -> PGF -> IOE ()
writeByteCode opts pgf
| elem FmtByteCode (flag optOutputFormats opts) =
let name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
file = name <.> "bc"
path = case flag optOutputDir opts of
Nothing -> file
Just dir -> dir </> file
in putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $
bracket
(openFile path WriteMode)
(hClose)
(\h -> do hSetBinaryMode h True
BSL.hPut h (encode addrs)
BSS.hPut h (code (abstract pgf)))
| otherwise = return ()
where
addrs =
[(id,addr) | (id,(_,_,_,_,addr)) <- Map.toList (funs (abstract pgf))] ++
[(id,addr) | (id,(_,_,addr)) <- Map.toList (cats (abstract pgf))]
writePGF :: Options -> PGF -> IOE ()
writePGF opts pgf = do
let outfile = grammarName opts pgf <.> "pgf"

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

@@ -278,8 +278,8 @@ functions pgf = Map.keys (funs (abstract pgf))
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
@@ -289,20 +289,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 $$
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,_,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)
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
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')

1
src/runtime/haskell/PGF/Binary.hs
View File

@@ -44,6 +44,7 @@ instance Binary Abstr where
cats <- get
return (Abstr{ aflags=aflags
, funs=funs, cats=cats
, code=BS.empty
})
instance Binary Concr where

19
src/runtime/haskell/PGF/Data.hs
View File

@@ -9,6 +9,7 @@ import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified GF.Data.TrieMap as TMap
import qualified Data.ByteString as BS
import Data.Array.IArray
import Data.Array.Unboxed
import Data.List
@@ -26,12 +27,13 @@ data PGF = PGF {
}
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)]) -- ^ 1. context of a category
-- ^ 2. functions of a category. The order in the list is important,
-- this is the order in which the type singatures are given in the source.
-- The termination of the exhaustive generation might depend on this.
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)],BCAddr), -- ^ 1. context of a category
-- ^ 2. functions of a category. The order in the list is important,
-- this is the order in which the type singatures are given in the source.
-- The termination of the exhaustive generation might depend on this.
code :: BS.ByteString
}
data Concr = Concr {
@@ -70,6 +72,7 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,
type Sequence = Array DotPos Symbol
type FunId = Int
type SeqId = Int
type BCAddr = Int
data Alternative =
Alt [Token] [String]
@@ -102,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.

30
src/runtime/haskell/PGF/Expr.hs
View File

@@ -318,22 +318,22 @@ data Value
| VClosure Env Expr
| VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- 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 eqs -> if a == 0
then case eqs of
Equ [] e : _ -> eval sig [] e
_ -> VConst f []
else VApp f []
Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
Just (_,a,meqs,_,_) -> case meqs of
Just eqs -> if a == 0
then case eqs of
Equ [] e : _ -> eval sig [] e
_ -> VConst f []
else VApp f []
Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
eval sig env (EMeta i) = case snd sig i of
@@ -347,11 +347,11 @@ 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
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

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

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

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

@@ -98,7 +98,7 @@ linTree pgf lang 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) =

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

@@ -21,18 +21,18 @@ 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
lookDef :: Abstr -> CId -> Maybe [Equation]
lookDef abs f =
case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
(_,a,eqs,_) -> eqs
(_,a,eqs,_,_) -> eqs
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
@@ -65,9 +65,9 @@ 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 ([],[]) cat $ cats $ abstract pgf
(_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
missingLins :: PGF -> CId -> [CId]
missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -81,7 +81,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf {
abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
cats = Map.map (\(hyps,fs) -> (hyps,filter (cond . snd) fs)) (cats abstr)
cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where

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

20
src/runtime/haskell/PGF/Printer.hs
View File

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

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

@@ -50,7 +50,7 @@ readProbabilitiesFromFile file pgf = do
mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs =
let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf]
cats1 = Map.map (\(_,fs) -> fill fs) (cats (abstract pgf))
cats1 = Map.map (\(_,fs,_) -> fill fs) (cats (abstract pgf))
in Probs funs1 cats1
where
fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
@@ -68,15 +68,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) -> fns) (cats (abstract pgf))
funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)),
catProbs = Map.map (\(_,fns,_) -> 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,_) fns -> (hypos,fns)) (cats (abstract pgf)) (catProbs probs)
funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
@@ -87,8 +87,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

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

@@ -39,7 +39,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
@@ -52,7 +52,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
@@ -68,7 +68,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

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

@@ -121,13 +121,13 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
lookupCatHyps :: CId -> TcM s [Hypo]
lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
Just (hyps,_) -> k hyps ms
Nothing -> h (UnknownCat cat))
Just (hyps,_,_) -> k hyps ms
Nothing -> h (UnknownCat cat))
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)
@@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
| cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
Just (_,fns) -> unTcM (mapM helper fns) abstr k h ms
Nothing -> h (UnknownCat cat))
Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
Nothing -> h (UnknownCat cat))
helper (p,fn) = do
ty <- lookupFunType fn