GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-15 06:02:55 -06:00
Code Issues Packages Projects Releases Wiki 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) if null (functionsToCat pgf id)
then empty then empty
else space $$ 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 return void
Nothing -> do putStrLn ("unknown category of function identifier "++show id) Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void return void
@@ -1246,7 +1246,7 @@ allCommands env@(pgf, mos) = Map.fromList [
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf 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 ++ " ;" showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
morphos opts s = 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"

16
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.Export
import GF.Compile.GeneratePMCFG import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF.CId import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString) import PGF.Data(fidInt,fidFloat,fidString)
@@ -41,26 +42,27 @@ mkCanon2pgf opts gr am = do
cncs <- mapM (mkConcr gr) (allConcretes gr am) cncs <- mapM (mkConcr gr) (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where 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 where
aflags = aflags =
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo]) concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
adefs = (adefs,bcode) =
generateByteCode $
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags] flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) | funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs] ((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c)) | cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, addr)) |
((m,c),AbsCat (Just (L _ cont))) <- adefs] ((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
catfuns cat = catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst)) (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 mkConcr gr cm = do
let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo, 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))))) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = 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 :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule = 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 :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] 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 :: (CId,(Type,Int,Maybe [Equation],Double,BCAddr)) -> JS.Property
absdef2js (f,(typ,_,_,_)) = absdef2js (f,(typ,_,_,_,_)) =
let (args,cat) = M.catSkeleton typ in 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)]) JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])

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

@@ -12,25 +12,25 @@ import Debug.Trace
grammar2lambdaprolog_mod pgf = render $ grammar2lambdaprolog_mod pgf = render $
text "module" <+> ppCId (absname pgf) <> char '.' $$ text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$ 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]] let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]]
where where
ppClauses cat fns = ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$ 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 $$ 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 space
grammar2lambdaprolog_sig pgf = render $ grammar2lambdaprolog_sig pgf = render $
text "sig" <+> ppCId (absname pgf) <> char '.' $$ text "sig" <+> ppCId (absname pgf) <> char '.' $$
space $$ 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 $$ 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 $$ space $$
vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (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))] 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 :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type" ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
@@ -157,7 +157,7 @@ expr2goal abstr scope goals i (EApp e1 e2) args =
in expr2goal abstr scope goals' i' e1 (e2':args) in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args = expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of case Map.lookup f (funs abstr) of
Just (_,_,Just _,_) -> let e = EFun (mkVar i) Just (_,_,Just _,_,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args) _ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args = expr2goal abstr scope goals i (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)] ++++ (f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])" plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] | [[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 ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
let args = reverse [EFun x | (_,x) <- subst]] ++++ let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])" plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] | [[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] ++++ let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)" plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] | [[plp fun, plp expr] |
(fun, (_, _, Just eqs, _)) <- Map.assocs (funs abs), (fun, (_, _, Just eqs, _, _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs] let (_, expr) = alphaConvert emptyEnv eqs]
) )
where plType cat args = plTerm (plp cat) (map plp args) 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 abs = abstract pgf
cncs = concretes pgf cncs = concretes pgf
pyAbsdef :: (Type, Int, Maybe [Equation], Double) -> String pyAbsdef :: (Type, Int, Maybe [Equation], Double, BCAddr) -> String
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args] pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ where (args, cat) = M.catSkeleton typ
pyLiteral :: Literal -> String pyLiteral :: Literal -> String

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

@@ -89,6 +89,7 @@ data OutputFormat = FmtPGFPretty
| FmtHaskell | FmtHaskell
| FmtProlog | FmtProlog
| FmtLambdaProlog | FmtLambdaProlog
| FmtByteCode
| FmtBNF | FmtBNF
| FmtEBNF | FmtEBNF
| FmtRegular | FmtRegular
@@ -436,6 +437,7 @@ outputFormatsExpl =
(("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("prolog", FmtProlog),"Prolog (whole grammar)"), (("prolog", FmtProlog),"Prolog (whole grammar)"),
(("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"), (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
(("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"), (("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"), (("ebnf", FmtEBNF),"Extended BNF"),
(("regular", FmtRegular),"* regular grammar"), (("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 -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs]) 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 -- * Questions to ask

26
src/compiler/GFC.hs
View File

@@ -18,6 +18,9 @@ import GF.Data.ErrM
import Data.Maybe import Data.Maybe
import Data.Binary 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 qualified Data.ByteString.Char8 as BS
import System.FilePath import System.FilePath
import System.IO import System.IO
@@ -48,6 +51,7 @@ compileSourceFiles opts fs =
then return () then return ()
else do pgf <- link opts (identC (BS.pack cnc)) gr else do pgf <- link opts (identC (BS.pack cnc)) gr
writePGF opts pgf writePGF opts pgf
writeByteCode opts pgf
writeOutputs opts pgf writeOutputs opts pgf
compileCFFiles :: Options -> [FilePath] -> IOE () compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -79,8 +83,30 @@ writeOutputs :: Options -> PGF -> IOE ()
writeOutputs opts pgf = do writeOutputs opts pgf = do
sequence_ [writeOutput opts name str sequence_ [writeOutput opts name str
| fmt <- flag optOutputFormats opts, | fmt <- flag optOutputFormats opts,
fmt /= FmtByteCode,
(name,str) <- exportPGF opts fmt pgf] (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 :: Options -> PGF -> IOE ()
writePGF opts pgf = do writePGF opts pgf = do
let outfile = grammarName opts pgf <.> "pgf" let outfile = grammarName opts pgf <.> "pgf"

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

@@ -278,7 +278,7 @@ functions pgf = Map.keys (funs (abstract pgf))
functionType pgf fun = functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_,_) -> Just ty Just (ty,_,_,_,_) -> Just ty
Nothing -> Nothing Nothing -> Nothing
-- | Converts an expression to normal form -- | Converts an expression to normal form
@@ -289,20 +289,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse pgf id = fmap (\def -> (def,producers,consumers)) definition browse pgf id = fmap (\def -> (def,producers,consumers)) definition
where where
definition = case Map.lookup id (funs (abstract pgf)) of 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 if null eqs
then empty then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts ds = map (ppPatt 9 scope) patts
in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) 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 Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
Nothing -> Nothing Nothing -> Nothing
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where where
accum f (ty,_,_,_) (plist,clist) = accum f (ty,_,_,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist let !plist' = if id `elem` ps then f : plist else plist
!clist' = if id `elem` cs then f : clist else clist !clist' = if id `elem` cs then f : clist else clist
in (plist',clist') in (plist',clist')

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

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

11
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.IntMap as IntMap
import qualified Data.IntSet as IntSet import qualified Data.IntSet as IntSet
import qualified GF.Data.TrieMap as TMap import qualified GF.Data.TrieMap as TMap
import qualified Data.ByteString as BS
import Data.Array.IArray import Data.Array.IArray
import Data.Array.Unboxed import Data.Array.Unboxed
import Data.List import Data.List
@@ -27,11 +28,12 @@ data PGF = PGF {
data Abstr = Abstr { data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag 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 funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)]) -- ^ 1. context of a category 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, -- ^ 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. -- this is the order in which the type singatures are given in the source.
-- The termination of the exhaustive generation might depend on this. -- The termination of the exhaustive generation might depend on this.
code :: BS.ByteString
} }
data Concr = Concr { data Concr = Concr {
@@ -70,6 +72,7 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,
type Sequence = Array DotPos Symbol type Sequence = Array DotPos Symbol
type FunId = Int type FunId = Int
type SeqId = Int type SeqId = Int
type BCAddr = Int
data Alternative = data Alternative =
Alt [Token] [String] Alt [Token] [String]
@@ -102,8 +105,8 @@ emptyPGF = PGF {
haveSameFunsPGF :: PGF -> PGF -> Bool haveSameFunsPGF :: PGF -> PGF -> Bool
haveSameFunsPGF one two = haveSameFunsPGF one two =
let let
fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))] fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))] fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))]
in fsone == fstwo in fsone == fstwo
-- | This is just a 'CId' with the language name. -- | This is just a 'CId' with the language name.

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

@@ -318,7 +318,7 @@ data Value
| VClosure Env Expr | VClosure Env Expr
| VImplArg Value | VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables , Int -> Maybe Expr -- lookup for metavariables
) )
type Env = [Value] type Env = [Value]
@@ -326,7 +326,7 @@ type Env = [Value]
eval :: Sig -> Env -> Expr -> Value eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of 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 Just eqs -> if a == 0
then case eqs of then case eqs of
Equ [] e : _ -> eval sig [] e Equ [] e : _ -> eval sig [] e
@@ -347,7 +347,7 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
apply sig env e [] = eval sig env e apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of 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 Just eqs -> if a <= length vs
then match sig f eqs vs then match sig f eqs vs
else VApp f 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 isLindefCId fun of cat = case isLindefCId fun of
Just cat -> cat Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of Nothing -> case Map.lookup fun (funs abs) of
Just (DTyp _ cat _,_,_,_) -> cat Just (DTyp _ cat _,_,_,_,_) -> cat
largs = map (render forest) args largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable) 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] Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where where
toApp fid (PApply funid pargs) = 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 (args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])] in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) = toApp _ (PCoerce fid) =

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

@@ -21,17 +21,17 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: Abstr -> CId -> Type lookType :: Abstr -> CId -> Type
lookType abs f = lookType abs f =
case lookMap (error $ "lookType " ++ show f) f (funs abs) of case lookMap (error $ "lookType " ++ show f) f (funs abs) of
(ty,_,_,_) -> ty (ty,_,_,_,_) -> ty
lookDef :: Abstr -> CId -> Maybe [Equation] lookDef :: Abstr -> CId -> Maybe [Equation]
lookDef abs f = lookDef abs f =
case lookMap (error $ "lookDef " ++ show f) f (funs abs) of case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
(_,a,eqs,_) -> eqs (_,a,eqs,_,_) -> eqs
isData :: Abstr -> CId -> Bool isData :: Abstr -> CId -> Bool
isData abs f = isData abs f =
case Map.lookup f (funs abs) of case Map.lookup f (funs abs) of
Just (_,_,Nothing,_) -> True -- the encoding of data constrs Just (_,_,Nothing,_,_) -> True -- the encoding of data constrs
_ -> False _ -> False
lookValCat :: Abstr -> CId -> CId lookValCat :: Abstr -> CId -> CId
@@ -65,9 +65,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat = 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 where
(_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
missingLins :: PGF -> CId -> [CId] missingLins :: PGF -> CId -> [CId]
missingLins pgf lang = [c | c <- fs, not (hasl c)] where missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -81,7 +81,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf { restrictPGF cond pgf = pgf {
abstract = abstr { abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs 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 } ---- restrict concrs also, might be needed
where 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)] isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | 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; ---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
---- cf. PGF.Tree.expr2tree ---- cf. PGF.Tree.expr2tree
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True

10
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 :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
ppCat :: CId -> ([Hypo],[(Double,CId)]) -> Doc ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc
ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
if null eqs if null eqs
then empty then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts ds = map (ppPatt 9 scope) patts
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] 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 f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc ppCnc :: Language -> Concr -> Doc
ppCnc name cnc = ppCnc name cnc =

12
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 -> Map.Map CId Double -> Probabilities
mkProbabilities pgf probs = mkProbabilities pgf probs =
let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf] 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 in Probs funs1 cats1
where where
fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs] 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 -> Probabilities
getProbabilities pgf = Probs { getProbabilities pgf = Probs {
funProbs = Map.map (\(_,_,_,p) -> p) (funs (abstract pgf)), funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)),
catProbs = Map.map (\(_,fns) -> fns) (cats (abstract pgf)) catProbs = Map.map (\(_,fns,_) -> fns) (cats (abstract pgf))
} }
setProbabilities :: Probabilities -> PGF -> PGF setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf { setProbabilities probs pgf = pgf {
abstract = (abstract pgf) { abstract = (abstract pgf) {
funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df,p)) (funs (abstract pgf)) (funProbs probs), funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_) fns -> (hypos,fns)) (cats (abstract pgf)) (catProbs probs) cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
}} }}
where where
mapUnionWith f map1 map2 = mapUnionWith f map1 map2 =
@@ -87,7 +87,7 @@ probTree :: PGF -> Expr -> Double
probTree pgf t = case t of probTree pgf t = case t of
EApp f e -> probTree pgf f * probTree pgf e EApp f e -> probTree pgf f * probTree pgf e
EFun f -> case Map.lookup f (funs (abstract pgf)) of EFun f -> case Map.lookup f (funs (abstract pgf)) of
Just (_,_,_,p) -> p Just (_,_,_,p,_) -> p
Nothing -> 1 Nothing -> 1
_ -> 1 _ -> 1

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 :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
isArg abs mtypes scid cid = isArg abs mtypes scid cid =
let p = Map.lookup cid $ funs abs let p = Map.lookup cid $ funs abs
(ty,_,_,_) = fromJust p (ty,_,_,_,_) = fromJust p
args = arguments ty args = arguments ty
setargs = Set.fromList args setargs = Set.fromList args
cond = Set.null $ Set.difference setargs scid cond = Set.null $ Set.difference setargs scid
@@ -52,7 +52,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
typesInterm abs fset = typesInterm abs fset =
let fs = funs abs let fs = funs abs
fsetTypes = Set.map (\x -> 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 (x,c)) fset
in Map.fromList $ Set.toList fsetTypes in Map.fromList $ Set.toList fsetTypes
@@ -68,7 +68,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat
returnCat :: Abstr -> CId -> CId returnCat :: Abstr -> CId -> CId
returnCat abs cid = returnCat abs cid =
let p = Map.lookup cid $ funs abs 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 " in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
else c else c

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

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