diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 18194f340..11ae46713 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -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 = diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs new file mode 100644 index 000000000..d5b18c725 --- /dev/null +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -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" diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index c30afb0ee..ae627f9e2 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -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, diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 90bb804c9..846b1df14 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -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 = diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index 1e9b00169..b7b3d5545 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -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)]) diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs index a9dc551f2..670e3a952 100644 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ b/src/compiler/GF/Compile/PGFtoLProlog.hs @@ -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) diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index 03a29871b..de50d86d1 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -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) diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index d81a531e2..00910171b 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], 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 diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 79e1b9f73..7408d0783 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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"), diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs index 57168c78c..23a07b62f 100644 --- a/src/compiler/GF/Speech/VoiceXML.hs +++ b/src/compiler/GF/Speech/VoiceXML.hs @@ -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 diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 3fff0701c..72a986303 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -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" diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index ac91fa231..b03349963 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -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') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 22a6ef464..e96bf0ea0 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index f382601a8..357dcc92e 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -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. diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 5fbcdf120..998819687 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 24bafb475..3c4272317 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 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) diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index 9181fdab2..39c59cd3f 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -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) = diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 7879004cd..88057ce45 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs index 92e3d12ce..015779ace 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 980b5dcdf..c0529b116 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -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 = diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index ee44e73e1..bf2464b1d 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -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 diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs index b5b5f4857..42b5d36d0 100644 --- a/src/runtime/haskell/PGF/SortTop.hs +++ b/src/runtime/haskell/PGF/SortTop.hs @@ -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 diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 890e77bb4..268742b94 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -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