diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index f1f47f044..a735b7adc 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -37,11 +37,11 @@ import Control.Exception --convertConcrete :: Options -> Abstr -> CId -> Concr -> IO Concr convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_defs = do - let env0 = emptyGrammarEnv cnc_defs cat_defs params + let env0 = emptyGrammarEnv cat_defs params when (flag optProf opts) $ do - profileGrammar lang cnc_defs env0 pfrules - env1 <- expandHOAS opts abs_defs cnc_defs cat_defs lin_defs env0 - env2 <- foldM (convertRule opts cnc_defs) env1 pfrules + profileGrammar lang env0 pfrules + env1 <- expandHOAS opts abs_defs cat_defs lin_defs env0 + env2 <- foldM (convertRule opts) env1 pfrules return $ getParserInfo flags printnames env2 where cat_defs = Map.insert cidVar (S []) lincats @@ -53,7 +53,7 @@ convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_ findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) -profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do +profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do hPutStrLn stderr "" hPutStrLn stderr ("Language: " ++ show lang) hPutStrLn stderr "" @@ -73,7 +73,7 @@ profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet pro hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1)) profileRule (PFRule fun args res ctypes ctype term) = do - let pargs = zipWith (protoFCat cnc_defs) args ctypes + let pargs = zipWith protoFCat args ctypes hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs])) lformat :: Show a => Int -> a -> String @@ -103,12 +103,12 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = count = length xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs -convertRule :: Options -> TermMap -> GrammarEnv -> ProtoFRule -> IO GrammarEnv -convertRule opts cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = do - let pres = protoFCat cnc_defs res ctype - pargs = zipWith (protoFCat cnc_defs) args ctypes +convertRule :: Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv +convertRule opts grammarEnv (PFRule fun args res ctypes ctype term) = do + let pres = protoFCat res ctype + pargs = zipWith protoFCat args ctypes - b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[]) + b = runBranchM (convertTerm [] ctype term) (pargs,[]) (grammarEnv1,b1) = addSequences' grammarEnv b grammarEnv2 = brk (\grammarEnv -> foldBM addRule grammarEnv @@ -185,8 +185,8 @@ data ProtoFRule = PFRule CId {- function -} type TermMap = Map.Map CId Term -protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat -protoFCat cnc_defs (n,cat) ctype = +protoFCat :: (Int,CId) -> Term -> ProtoFCat +protoFCat (n,cat) ctype = let (rcs,tcs) = loop [] [] [] ctype' in PFCat n cat rcs tcs where @@ -199,9 +199,6 @@ protoFCat cnc_defs (n,cat) ctype = loop path rcs tcs (R record) = List.foldr (\(index,term) (rcs,tcs) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) loop path rcs tcs (S _) = (path:rcs, tcs) - loop path rcs tcs (F id) = case Map.lookup id cnc_defs of - Just term -> loop path rcs tcs term - Nothing -> error ("unknown identifier: "++show id) data Branch a = Case Int FPath [Branch a] @@ -254,29 +251,23 @@ optimizeLin lin@(SymKS _ : _) = optimizeLin (sym : lin) = sym : optimizeLin lin -convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [Symbol]) -convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel) -convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel) -convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record -convertTerm cnc_defs sel ctype (P term p) = do nr <- evalTerm cnc_defs [] p - convertTerm cnc_defs (nr:sel) ctype term -convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars - convertTerm cnc_defs sel ctype term -convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts - return (Str (concat [s | Str s <- vs])) -convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [SymKS [t]]) -convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [SymKP s v]) -convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of - Just term -> convertTerm cnc_defs sel ctype term - Nothing -> error ("unknown id " ++ showCId id) -convertTerm cnc_defs sel ctype (W s t) = do +convertTerm :: FPath -> Term -> Term -> CnvMonad (Value [Symbol]) +convertTerm sel ctype (V nr) = convertArg ctype nr (reverse sel) +convertTerm sel ctype (C nr) = convertCon ctype nr (reverse sel) +convertTerm sel ctype (R record) = convertRec sel ctype record +convertTerm sel ctype (P term p) = do nr <- evalTerm [] p + convertTerm (nr:sel) ctype term +convertTerm sel ctype (FV vars) = do term <- variants vars + convertTerm sel ctype term +convertTerm sel ctype (S ts) = do vs <- mapM (convertTerm sel ctype) ts + return (Str (concat [s | Str s <- vs])) +convertTerm sel ctype (K (KS t)) = return (Str [SymKS [t]]) +convertTerm sel ctype (K (KP s v))=return (Str [SymKP s v]) +convertTerm sel ctype (W s t) = do ss <- case t of R ss -> return ss - F f -> case Map.lookup f cnc_defs of - Just (R ss) -> return ss - _ -> error ("unknown id " ++ showCId f) - convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] -convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")") + convertRec sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] +convertTerm sel ctype x = error ("convertTerm ("++show x++")") convertArg :: Term -> Int -> FPath -> CnvMonad (Value [Symbol]) convertArg (R ctypes) nr path = do @@ -299,27 +290,24 @@ convertArg (S _) nr path = do convertCon (C max) index [] = return (Con index) convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x -convertRec cnc_defs [] (R ctypes) record = do - mkRecord (zipWith (convertTerm cnc_defs []) ctypes record) -convertRec cnc_defs (index:sub_sel) ctype record = - convertTerm cnc_defs sub_sel ctype (record !! index) +convertRec [] (R ctypes) record = do + mkRecord (zipWith (convertTerm []) ctypes record) +convertRec (index:sub_sel) ctype record = + convertTerm sub_sel ctype (record !! index) ------------------------------------------------------------ -- eval a term to ground terms -evalTerm :: TermMap -> FPath -> Term -> CnvMonad LIndex -evalTerm cnc_defs path (V nr) = choices nr (reverse path) -evalTerm cnc_defs path (C nr) = return nr -evalTerm cnc_defs path (R record) = case path of - (index:path) -> evalTerm cnc_defs path (record !! index) -evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel - evalTerm cnc_defs (index:path) term -evalTerm cnc_defs path (FV terms) = variants terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of - Just term -> evalTerm cnc_defs path term - Nothing -> error ("unknown id " ++ showCId id) -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") +evalTerm :: FPath -> Term -> CnvMonad LIndex +evalTerm path (V nr) = choices nr (reverse path) +evalTerm path (C nr) = return nr +evalTerm path (R record) = case path of + (index:path) -> evalTerm path (record !! index) +evalTerm path (P term sel) = do index <- evalTerm [] sel + evalTerm (index:path) term +evalTerm path (FV terms) = variants terms >>= evalTerm path +evalTerm path x = error ("evalTerm ("++show x++")") ---------------------------------------------------------------------- @@ -331,7 +319,7 @@ type SeqSet = Map.Map Sequence SeqId type FunSet = Map.Map CncFun FunId type CoerceSet= Map.Map [FId] FId -emptyGrammarEnv cnc_defs lincats params = +emptyGrammarEnv lincats params = let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty where @@ -347,9 +335,6 @@ emptyGrammarEnv cnc_defs lincats params = getMultipliers m ms (R record) = foldr (\t (m,ms) -> getMultipliers m ms t) (m,ms) record getMultipliers m ms (S _) = (m,ms) getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) - getMultipliers m ms (F id) = case Map.lookup id cnc_defs of - Just term -> getMultipliers m ms term - Nothing -> error ("unknown identifier: "++showCId id) getLabels ls (R record) = concat [getLabels (l:ls) t | P (K (KS l)) t <- record] getLabels ls (S [FV ps,t]) = concat [getLabels (l:ls) t | K (KS l) <- ps] @@ -357,7 +342,7 @@ emptyGrammarEnv cnc_defs lincats params = getLabels ls (FV _) = [] getLabels _ t = error (show t) -expandHOAS opts abs_defs cnc_defs lincats lindefs env = +expandHOAS opts abs_defs lincats lindefs env = foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats) where hoTypes :: [(Int,CId)] @@ -388,13 +373,13 @@ expandHOAS opts abs_defs cnc_defs lincats lindefs env = where (arg,res) = case Map.lookup cat lincats of Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) + Just ctype -> (protoFCat (0,cat) ctype, protoFCat (n,cat) ctype) -- add one PMCFG function for each high-order category: _V : Var -> Cat add_varFun env cat = case Map.lookup cat lindefs of Nothing -> return env - Just lindef -> convertRule opts cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) + Just lindef -> convertRule opts env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) where arg = case Map.lookup cidVar lincats of diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index f6725bf4f..d756af5cd 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -57,30 +57,6 @@ concrete2js (c,cnc) = JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start) ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)]) - -cncdef2js :: String -> String -> (CId,Term) -> JS.Property -cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - R xs -> new "Arr" (map f xs) - P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] - S xs -> mkSeq (map f xs) - K t -> tokn2js t - V i -> JS.EIndex (JS.EVar children) (JS.EInt i) - C i -> new "Int" [JS.EInt i] - F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children] - FV xs -> new "Variants" (map f xs) - W str x -> new "Suffix" [JS.EStr str, f x] - TM _ -> new "Meta" [] - -tokn2js :: Tokn -> JS.Expr -tokn2js (KS s) = mkStr s -tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME - mkStr :: String -> JS.Expr mkStr s = new "Str" [JS.EStr s] diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index 9e390e87b..8c5dee166 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -116,32 +116,6 @@ instance PLPrint Patt where instance PLPrint Equation where plp (Equ patterns result) = plOper ":" (plp patterns) (plp result) -instance PLPrint Term where - plp (S terms) = plTerm "s" [plp terms] - plp (C n) = plTerm "c" [show n] - plp (K tokn) = plTerm "k" [plp tokn] - plp (FV trms) = plTerm "fv" [plp trms] - plp (P t1 t2) = plTerm "p" [plp t1, plp t2] - plp (W s trm) = plTerm "w" [plp s, plp trm] - plp (R terms) = plTerm "r" [plp terms] - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "v" [show n] - plp (TM str) = plTerm "tm" [plp str] - -{-- more prolog-like syntax for PGF terms, but also more difficult to handle: -instance PLPrint Term where - plp (S terms) = plp terms - plp (C n) = show n - plp (K token) = plp token - plp (FV terms) = prCurlyList (map plp terms) - plp (P t1 t2) = plOper "/" (plp t1) (plp t2) - plp (W s trm) = plOper "+" (plp s) (plp trm) - plp (R terms) = plTerm "r" (map plp terms) - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "arg" [show n] - plp (TM str) = plTerm "meta" [plp str] ---} - instance PLPrint CId where plp cid | isLogicalVariable str || cid == wildCId = plVar str diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 241c9cc99..623cbe7bb 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -72,34 +72,6 @@ instance Binary Alternative where put (Alt v x) = put (v,x) get = liftM2 Alt get get -instance Binary Term where - put (R es) = putWord8 0 >> put es - put (S es) = putWord8 1 >> put es - put (FV es) = putWord8 2 >> put es - put (P e v) = putWord8 3 >> put (e,v) - put (W e v) = putWord8 4 >> put (e,v) - put (C i ) = putWord8 5 >> put i - put (TM i ) = putWord8 6 >> put i - put (F f) = putWord8 7 >> put f - put (V i) = putWord8 8 >> put i - put (K (KS s)) = putWord8 9 >> put s - put (K (KP d vs)) = putWord8 10 >> put (d,vs) - - get = do tag <- getWord8 - case tag of - 0 -> liftM R get - 1 -> liftM S get - 2 -> liftM FV get - 3 -> liftM2 P get get - 4 -> liftM2 W get get - 5 -> liftM C get - 6 -> liftM TM get - 7 -> liftM F get - 8 -> liftM V get - 9 -> liftM (K . KS) get - 10 -> liftM2 (\d vs -> K (KP d vs)) get get - _ -> decodingError - instance Binary Expr where put (EAbs b x exp) = putWord8 0 >> put (b,x,exp) put (EApp e1 e2) = putWord8 1 >> put (e1,e2) diff --git a/src/runtime/haskell/PGF/Check.hs b/src/runtime/haskell/PGF/Check.hs index 8f3b82eb7..94713a745 100644 --- a/src/runtime/haskell/PGF/Check.hs +++ b/src/runtime/haskell/PGF/Check.hs @@ -137,14 +137,6 @@ lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of vlinc (i,c) = case linc c of R ts -> R (ts ++ replicate i str) -inline :: PGFSig -> CId -> Term -> Term -inline pgf lang t = case t of - F c -> inl $ look c - _ -> composSafeOp inl t - where - inl = inline pgf lang - look = lookLin pgf lang - composOp :: Monad m => (Term -> m Term) -> Term -> m Term composOp f trm = case trm of R ts -> liftM R $ mapM f ts diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 7623a05f3..12f945151 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -75,7 +75,6 @@ data Term = | K Tokn | V Int | C Int - | F CId | FV [Term] | W String Term | TM String