From b0e110cf4f7c6e43d044f05fdedde3ffaabb9843 Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 9 Aug 2010 10:10:08 +0000 Subject: [PATCH] native representation for HOAS in PMCFG and incremental type checking of the parse forest --- src/compiler/GF/Command/Commands.hs | 3 +- src/compiler/GF/Compile/ExampleBased.hs | 2 + src/compiler/GF/Compile/GeneratePMCFG.hs | 241 ++++++++++++----------- src/compiler/GF/Compile/PGFtoJS.hs | 13 +- src/compiler/GF/Infra/Option.hs | 2 +- src/compiler/GF/Speech/PGFToCFG.hs | 8 +- src/runtime/haskell/PGF/Binary.hs | 19 +- src/runtime/haskell/PGF/Data.hs | 5 +- src/runtime/haskell/PGF/Forest.hs | 175 ++++++++++------ src/runtime/haskell/PGF/Linearize.hs | 117 +++++------ src/runtime/haskell/PGF/Macros.hs | 34 +++- src/runtime/haskell/PGF/Optimize.hs | 91 +++++---- src/runtime/haskell/PGF/Parse.hs | 174 ++++++++-------- src/runtime/haskell/PGF/Printer.hs | 15 +- src/runtime/haskell/PGF/TypeCheck.hs | 62 +++--- src/runtime/haskell/PGF/VisualizeTree.hs | 18 +- src/server/PGFService.hs | 1 + 17 files changed, 544 insertions(+), 436 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 54bcb9e70..3d97f545a 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1013,8 +1013,9 @@ allCommands env@(pgf, mos) = Map.fromList [ TypeError errs -> ([], render (text "The parsing is successful but the type checking failed with error(s):" $$ nest 2 (vcat (map (ppTcError . snd) errs))) ++ "\n" ++ msg) - ParseFailed i -> ([], "parse failed at token " ++ show (words s !! max 0 (i-1)) + ParseFailed i -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1)) ++ "\n" ++ msg) + ParseIncomplete-> ([], "The sentence is not complete") where (es,msg) = fromParse opts ps diff --git a/src/compiler/GF/Compile/ExampleBased.hs b/src/compiler/GF/Compile/ExampleBased.hs index 74a07426f..20fa4d62f 100644 --- a/src/compiler/GF/Compile/ExampleBased.hs +++ b/src/compiler/GF/Compile/ExampleBased.hs @@ -51,6 +51,8 @@ convertFile conf src file = do return ws TypeError _ -> return [] + ParseIncomplete -> + return [] ParseOk ts -> case rank ts of (t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >> diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index c245c3595..7610f286c 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -44,21 +44,26 @@ import Control.Exception convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr convertConcrete opts0 gr am cm = do - let env0 = emptyGrammarEnv gr cm + let env = emptyGrammarEnv gr cm when (flag optProf opts) $ do - profileGrammar cm env0 pfrules - env1 <- expandHOAS opts cm env0 - env2 <- foldM (convertRule gr opts) env1 pfrules - return $ getConcr flags printnames env2 + profileGrammar cm env pfrules + env <- foldM (convertLinDef gr opts) env pflindefs + env <- foldM (convertRule gr opts) env pfrules + return $ getConcr flags printnames env where (m,mo) = cm opts = addOptions (M.flags (snd am)) opts0 + pflindefs = [ + ((m,id),term,lincat) | + (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (M.jments mo)] + pfrules = [ - (PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) | + (PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) | (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo), - let (args,res) = err error typeSkeleton (lookupFunType gr (fst am) id)] + let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id) + args = [catSkeleton ty | (_,_,ty) <- ctxt]] flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (M.flags mo)] @@ -75,15 +80,13 @@ convertConcrete opts0 gr am cm = do i2i :: Ident -> CId i2i = CId . ident2bs -profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do +profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do hPutStrLn stderr "" hPutStrLn stderr ("Language: " ++ showIdent m) hPutStrLn stderr "" hPutStrLn stderr "Categories Count" hPutStrLn stderr "--------------------------------" - case IntMap.lookup 0 catSet of - Just cats -> mapM_ profileCat (Map.toList cats) - Nothing -> return () + mapM_ profileCat (Map.toList catSet) hPutStrLn stderr "--------------------------------" hPutStrLn stderr "" hPutStrLn stderr "Rules Count" @@ -98,8 +101,8 @@ profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSe let pargs = map (protoFCat env) args hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args)))) where - catFactor (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = - case IntMap.lookup n catSet >>= Map.lookup cat of + catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) = + case Map.lookup cat catSet of Just (s,e,_) -> e-s+1 Nothing -> 0 @@ -109,12 +112,40 @@ profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSe rformat :: Int -> String -> String rformat n s = replicate (n-length s) ' ' ++ s -data ProtoFRule = PFRule Ident {- function -} - [(Int,Cat)] {- argument types: context size and category -} - (Int,Cat) {- result type : context size (always 0) and category -} - [Type] {- argument lin-types representation -} - Type {- result lin-type representation -} - Term {- body -} +data ProtoFRule = PFRule Ident {- function -} + [([Cat],Cat)] {- argument types: context size and category -} + ([Cat],Cat) {- result type : context size (always 0) and category -} + [Type] {- argument lin-types representation -} + Type {- result lin-type representation -} + Term {- body -} + +optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv +optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) = + IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet + where + optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps]) + where + ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv + ff funid xs env + | product (map Set.size ys) == count + = case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of + (env,args) -> let xs = sequence (zipWith addContext pargs args) + in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs + | otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args) + in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs + where + count = length xs + ys = foldr (zipWith Set.insert) (repeat Set.empty) xs + + addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt + return (PArg hyps fid) + + toCncHypo cat = + case Map.lookup cat catSet of + Just (s,e,_) -> do fid <- range (s,e) + guard (fid `IntMap.member` lindefSet) + return (fidVar,fid) + Nothing -> mzero convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do @@ -123,12 +154,13 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[]) (grammarEnv1,b1) = addSequencesB grammarEnv b - grammarEnv2 = brk (\grammarEnv -> foldBM addRule - grammarEnv - (goB b1 CNil []) - (pres,pargs) ) grammarEnv1 + grammarEnv2 = foldBM addRule + grammarEnv1 + (goB b1 CNil []) + (pres,pargs) + grammarEnv3 = optimize pargs grammarEnv2 when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun) - return $! grammarEnv2 + return $! grammarEnv3 where addRule lins (newCat', newArgs') env0 = let [newCat] = getFIds env0 newCat' @@ -136,24 +168,28 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do (env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins)) - in addProduction env2 newCat (PApply funid newArgs) + in addApplication env2 newCat (funid,newArgs) -brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) -brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = - case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of - (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 +convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv +convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do + let pres = protoFCat grammarEnv ([],cat) + parg = protoFCat grammarEnv ([],(identW,cVar)) + + b = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[]) + (grammarEnv1,b1) = addSequencesB grammarEnv b + grammarEnv2 = foldBM addRule + grammarEnv1 + (goB b1 CNil []) + (pres,[parg]) + when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId) + return $! grammarEnv2 where - optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | PApply funid args <- Set.toList ps]) - where - ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv - ff funid xs env - | product (map Set.size ys) == count = - case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of - (env,args) -> addProduction env cat (PApply funid args) - | otherwise = List.foldl (\env args -> addProduction env cat (PApply funid args)) env xs - where - count = length xs - ys = foldr (zipWith Set.insert) (repeat Set.empty) xs + lindefCId = mkCId ("lindef "++showIdent (snd cat)) + + addRule lins (newCat', newArgs') env0 = + let [newCat] = getFIds env0 newCat' + (env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins)) + in addLinDef env1 newCat funid unfactor :: Term -> CnvMonad Term unfactor t = CM (\gr c -> c (unfac gr t)) @@ -270,13 +306,13 @@ data Path -- The annotations are as follows: the strings are annotated with -- their index in the PMCFG tuple, the parameters are annotated -- with their value both as term and as index. -data ProtoFCat = PFCat Int Ident (Schema Identity Int (Int,[(Term,Int)])) +data ProtoFCat = PFCat [Ident] Ident Proto type Env = (ProtoFCat, [ProtoFCat]) -protoFCat :: GrammarEnv -> (Int,Cat) -> ProtoFCat -protoFCat (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = - case IntMap.lookup n catSet >>= Map.lookup cat of - Just (_,_,pfcat) -> pfcat +protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat +protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) = + case Map.lookup cat catSet of + Just (_,_,proto) -> PFCat (map snd ctxt) cat proto Nothing -> error "unknown category" ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path @@ -330,8 +366,9 @@ convertArg opts (Sort _) nr path = do (args,_) <- get let PFCat _ cat schema = args !! nr l = index (reversePath path) schema - sym | isLiteralCat opts cat = SymLit nr l - | otherwise = SymCat nr l + sym | CProj (LVar i) CNil <- path = SymVar nr i + | isLiteralCat opts cat = SymLit nr l + | otherwise = SymCat nr l return (CStr [sym]) where index (CProj lbl path) (CRec rs) = case lookup lbl rs of @@ -391,7 +428,7 @@ addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b in (env',(trm,b'))) env vs in (env1,CTbl pt vs1) -addSequencesV env (CStr lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) +addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin) in (env1,CStr seqid) addSequencesV env (CPar i) = (env,CPar i) @@ -441,25 +478,30 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd ---------------------------------------------------------------------- -- GrammarEnv -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) -type CatSet = IntMap.IntMap (Map.Map Ident (FId,FId,ProtoFCat)) +data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet +type Proto = Schema Identity Int (Int,[(Term,Int)]) +type CatSet = Map.Map Ident (FId,FId,Proto) type SeqSet = Map.Map Sequence SeqId type FunSet = Map.Map CncFun FunId +type LinDefSet= IntMap.IntMap [FunId] type CoerceSet= Map.Map [FId] FId +type AppSet = IntMap.IntMap (Set.Set (FunId,[FId])) +type ProdSet = IntMap.IntMap (Set.Set Production) emptyGrammarEnv gr (m,mo) = 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 + in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty where computeCatRange index cat ctype - | cat == cString = (index,(fidString,fidString,PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) - | cat == cInt = (index,(fidInt, fidInt, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) - | cat == cFloat = (index,(fidFloat, fidFloat, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) - | otherwise = (index+size,(index,index+size-1,PFCat 0 cat schema)) + | cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))])) + | cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))])) + | cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))])) + | cat == cVar = (index,(fidFloat, fidFloat, CStr 0)) + | otherwise = (index+size,(index,index+size-1,schema)) where ((_,size),schema) = compute (0,1) ctype - compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t + compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t in (st',(lbl,Identity t'))) st rs in (st',CRec rs') compute st (Table pt vt) = let vs = err error id (allParamValues gr pt) @@ -478,96 +520,55 @@ emptyGrammarEnv gr (m,mo) = Map.fromAscList [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)] +addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv +addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p = + GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet -expandHOAS opts (m,mo) env = return env {- - foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats) - where - hoTypes :: [(Int,CId)] - hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- Map.toList abs_defs - , (n,c) <- fst (typeSkeleton ty), n > 0] - - -- add a range of PMCFG categories for each GF high-order category - add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) = - case IntMap.lookup 0 catSet >>= Map.lookup cat of - Just (start,end,ms,lbls) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms,lbls)) catSet - !last_id' = last_id+(end-start)+1 - in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet) - Nothing -> env - - -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat - add_hoFun env (n,cat) = - let linRec = [[SymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++ - [[SymLit i 0] | i <- [1..n]] - (env1,lins) = List.mapAccumL addFSeq env linRec - newLinRec = mkArray lins - - (env2,funid) = addCncFun env1 (CncFun _B newLinRec) - - env3 = foldl (\env (arg,res) -> addProduction env res (PApply funid (arg : replicate n fcatVar))) - env2 - (zip (getFIds env2 arg) (getFIds env2 res)) - in env3 - where - (arg,res) = case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - 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 env (PFRule _V [(0,cVar)] (0,cat) [arg] res lindef) - where - arg = - case Map.lookup cVar lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> ctype - - res = - case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> ctype --} addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) +addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p = + GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) -addFSeq :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId) -addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst = +addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId) +addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst = case Map.lookup seq seqSet of Just id -> (env,id) Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq) + in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq) where seq = mkArray lst addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId) -addCncFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = +addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun = case Map.lookup fun funSet of Just id -> (env,id) Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) + in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid) addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId) -addCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = +addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats = case sub_fcats of [fcat] -> (env,fcat) _ -> case Map.lookup sub_fcats crcSet of Just fcat -> (env,fcat) Nothing -> let !fcat = last_id+1 - in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) + in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat) + +addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv +addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid = + GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr -getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = +getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) = Concr { cflags = flags , printnames = printnames , cncfuns = mkSetArray funSet + , lindefs = lindefSet , sequences = mkSetArray seqSet , productions = IntMap.union prodSet coercions , pproductions = IntMap.empty , lproductions = Map.empty , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema)))) - | (cat,(start,end,PFCat _ _ schema)) <- maybe [] Map.toList (IntMap.lookup 0 catSet)] + | (cat,(start,end,schema)) <- Map.toList catSet] , totalCats = last_id+1 } where @@ -585,8 +586,8 @@ getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSe getFIds :: GrammarEnv -> ProtoFCat -> [FId] -getFIds (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) = - case IntMap.lookup n catSet >>= Map.lookup cat of +getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) = + case Map.lookup cat catSet of Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ()) where variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs @@ -611,9 +612,9 @@ restrictHead path term = do put (head, args) restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat -restrictProtoFCat path v (PFCat n cat schema) = do +restrictProtoFCat path v (PFCat ctxt cat schema) = do schema <- addConstraint path v schema - return (PFCat n cat schema) + return (PFCat ctxt cat schema) where addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index d756af5cd..b81e0c5d3 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -71,19 +71,22 @@ children :: JS.Ident children = JS.Ident "cs" frule2js :: Production -> JS.Expr -frule2js (PApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)] +frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)] frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg] +farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid]) + ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] seq2js :: Array.Array DotPos Symbol -> JS.Expr seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] sym2js :: Symbol -> JS.Expr -sym2js (SymCat n l) = new "Arg" [JS.EInt n, JS.EInt l] -sym2js (SymLit n l) = new "Lit" [JS.EInt n, JS.EInt l] -sym2js (SymKS ts) = new "KS" (map JS.EStr ts) -sym2js (SymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] +sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l] +sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l] +sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l] +sym2js (SymKS ts) = new "SymKS" (map JS.EStr ts) +sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)] diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index d76302827..a45d46a39 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -247,7 +247,7 @@ defaultFlags = Flags { optOutputFormats = [], optSISR = Nothing, optHaskellOptions = Set.empty, - optLiteralCats = Set.fromList [cString,cInt,cFloat], + optLiteralCats = Set.fromList [cString,cInt,cFloat,cVar], optLexicalCats = Set.empty, optGFODir = Nothing, optOutputFile = Nothing, diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs index cead72f40..01c16393e 100644 --- a/src/compiler/GF/Speech/PGFToCFG.hs +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -86,13 +86,11 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co mkRhs = concatMap symbolToCFSymbol . Array.elems containsLiterals :: Array DotPos Symbol -> Bool - containsLiterals row = any isPredefFId [args!!n | SymCat n _ <- Array.elems row] || - not (null [n | SymLit n _ <- Array.elems row]) -- only this is needed for PMCFG. - -- The first line is for backward compat. + containsLiterals row = not (null ([n | SymLit n _ <- Array.elems row] ++ + [n | SymVar n _ <- Array.elems row])) symbolToCFSymbol :: Symbol -> [CFSymbol] - symbolToCFSymbol (SymCat n l) = [NonTerminal (fcatToCat (args!!n) l)] - symbolToCFSymbol (SymLit n l) = [NonTerminal (fcatToCat (args!!n) l)] + symbolToCFSymbol (SymCat n l) = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)] symbolToCFSymbol (SymKS ts) = map Terminal ts symbolToCFSymbol (SymKP ts as) = map Terminal $ ts ---- ++ [t | Alt ss _ <- as, t <- ss] diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 1f61c5749..26f994797 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -51,6 +51,7 @@ instance Binary Concr where put (printnames cnc) putArray2 (sequences cnc) putArray (cncfuns cnc) + put (lindefs cnc) put (productions cnc) put (cnccats cnc) put (totalCats cnc) @@ -58,11 +59,13 @@ instance Binary Concr where printnames <- get sequences <- getArray2 cncfuns <- getArray + lindefs <- get productions <- get cnccats <- get totalCats <- get return (Concr{ cflags=cflags, printnames=printnames - , sequences=sequences, cncfuns=cncfuns, productions=productions + , sequences=sequences, cncfuns=cncfuns, lindefs=lindefs + , productions=productions , pproductions = IntMap.empty , lproductions = Map.empty , cnccats=cnccats, totalCats=totalCats @@ -141,16 +144,22 @@ instance Binary CncCat where instance Binary Symbol where put (SymCat n l) = putWord8 0 >> put (n,l) put (SymLit n l) = putWord8 1 >> put (n,l) - put (SymKS ts) = putWord8 2 >> put ts - put (SymKP d vs) = putWord8 3 >> put (d,vs) + put (SymVar n l) = putWord8 2 >> put (n,l) + put (SymKS ts) = putWord8 3 >> put ts + put (SymKP d vs) = putWord8 4 >> put (d,vs) get = do tag <- getWord8 case tag of 0 -> liftM2 SymCat get get 1 -> liftM2 SymLit get get - 2 -> liftM SymKS get - 3 -> liftM2 (\d vs -> SymKP d vs) get get + 2 -> liftM2 SymVar get get + 3 -> liftM SymKS get + 4 -> liftM2 (\d vs -> SymKP d vs) get get _ -> decodingError +instance Binary PArg where + put (PArg hypos fid) = put (map snd hypos,fid) + get = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid) + instance Binary Production where put (PApply ruleid args) = putWord8 0 >> put (ruleid,args) put (PCoerce fcat) = putWord8 1 >> put fcat diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 490e25a84..ec119fc0d 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -36,6 +36,7 @@ data Concr = Concr { cflags :: Map.Map CId Literal, -- value of a flag printnames :: Map.Map CId String, -- printname of a cat or a fun cncfuns :: Array FunId CncFun, + lindefs :: IntMap.IntMap [FunId], sequences :: Array SeqId Sequence, productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing @@ -51,14 +52,16 @@ type DotPos = Int data Symbol = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int | SymKS [Token] | SymKP [Token] [Alternative] deriving (Eq,Ord,Show) data Production - = PApply {-# UNPACK #-} !FunId [FId] + = PApply {-# UNPACK #-} !FunId [PArg] | PCoerce {-# UNPACK #-} !FId | PConst CId Expr [Token] deriving (Eq,Ord,Show) +data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String) data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show) type Sequence = Array DotPos Symbol diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index f814e3f4f..58f0209a8 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -14,12 +14,14 @@ module PGF.Forest( Forest(..) , BracketedString, showBracketedString, lengthBracketedString , linearizeWithBrackets + , getAbsTrees , foldForest ) where import PGF.CId import PGF.Data import PGF.Macros +import PGF.TypeCheck import Data.List import Data.Array.IArray import qualified Data.Set as Set @@ -34,7 +36,7 @@ data Forest { abstr :: Abstr , concr :: Concr , forest :: IntMap.IntMap (Set.Set Production) - , root :: [([Symbol],[FId])] + , root :: [([Symbol],[PArg])] } -------------------------------------------------------------------- @@ -51,29 +53,39 @@ linearizeWithBrackets = head . snd . untokn "" . bracketedTokn bracketedTokn :: Forest -> BracketedTokn bracketedTokn f@(Forest abs cnc forest root) = - case [computeSeq seq (map (render forest) args) | (seq,args) <- root] of + case [computeSeq isTrusted seq (map (render forest) args) | (seq,args) <- root] of ([bs@(Bracket_ _ _ _ _ _)]:_) -> bs (bss:_) -> Bracket_ wildCId 0 0 [] bss [] -> Bracket_ wildCId 0 0 [] [] where + isTrusted (_,fid) = IntSet.member fid trusted + trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root] - render forest fid = + render forest arg@(PArg hypos fid) = case IntMap.lookup fid forest >>= Set.maxView of - Just (p,set) -> descend (if Set.null set then forest else IntMap.insert fid set forest) p + Just (p,set) -> let (ct,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p + in (ct,es,(map getVar hypos,lin)) Nothing -> error ("wrong forest id " ++ show fid) where descend forest (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid - Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs) - largs = map (render forest) args - ltable = listArray (bounds lins) - [computeSeq (elems (sequences cnc ! seqid)) largs | - seqid <- elems lins] - in (fid,cat,ltable) - descend forest (PCoerce fid) = render forest fid - descend forest (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]]) + cat = case isLindefCId fun of + Just cat -> cat + Nothing -> case Map.lookup fun (funs abs) of + Just (DTyp _ cat _,_,_) -> cat + largs = map (render forest) args + ltable = mkLinTable cnc isTrusted [] funid largs + in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable) + descend forest (PCoerce fid) = render forest (PArg [] fid) + descend forest (PConst cat e ts) = ((cat,fid),[e],([],listArray (0,0) [[LeafKS ts]])) - trustedSpots parents fid + getVar (fid,_) + | fid == fidVar = wildCId + | otherwise = x + where + (x:_) = [x | PConst _ (EFun x) _ <- maybe [] Set.toList (IntMap.lookup fid forest)] + + trustedSpots parents (PArg _ fid) | fid < totalCats cnc || -- forest ids from the grammar correspond to metavariables IntSet.member fid parents -- this avoids loops in the grammar = IntSet.empty @@ -85,65 +97,116 @@ bracketedTokn f@(Forest abs cnc forest root) = parents' = IntSet.insert fid parents descend (PApply funid args) = IntSet.unions (map (trustedSpots parents') args) - descend (PCoerce fid) = trustedSpots parents' fid + descend (PCoerce fid) = trustedSpots parents' (PArg [] fid) descend (PConst c e _) = IntSet.empty - computeSeq :: [Symbol] -> [(FId,CId,LinTable)] -> [BracketedTokn] - computeSeq seq args = concatMap compute seq - where - compute (SymCat d r) = getArg d r - compute (SymLit d r) = getArg d r - compute (SymKS ts) = [LeafKS ts] - compute (SymKP ts alts) = [LeafKP ts alts] - - getArg d r - | not (null arg_lin) && - IntSet.member fid trusted - = [Bracket_ cat fid r es arg_lin] - | otherwise = arg_lin - where - arg_lin = lin ! r - (fid,cat,lin) = args !! d - es = getAbsTrees f fid +isLindefCId id + | take l s == lindef = Just (mkCId (drop l s)) + | otherwise = Nothing + where + s = showCId id + lindef = "lindef " + l = length lindef -- | This function extracts the list of all completed parse trees -- that spans the whole input consumed so far. The trees are also -- limited by the category specified, which is usually -- the same as the startup category. -getAbsTrees :: Forest -> FId -> [Expr] -getAbsTrees (Forest abs cnc forest root) fid = - nubsort $ do (fvs,e) <- go Set.empty 0 (0,fid) - guard (Set.null fvs) - return e +getAbsTrees :: Forest -> PArg -> Maybe Type -> Either [(FId,TcError)] [Expr] +getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty = + let (res,err) = unTcFM (do e <- go Set.empty emptyScope arg (fmap (TTyp []) ty) + e <- runTcM abs fid (refineExpr e) + runTcM abs fid (checkResolvedMetaStore emptyScope e) + return e) IntMap.empty + in if null res + then Left (nub err) + else Right (nubsort (map snd res)) where - go rec_ fcat' (d,fcat) - | fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments - | Set.member fcat rec_ = mzero - | otherwise = foldForest (\funid args trees -> + go rec_ scope_ (PArg hypos fid) mb_tty_ + | fid < totalCats cnc = case mb_tty of + Just tty -> do i <- runTcM abs fid (newMeta scope tty) + return (mkAbs (EMeta i)) + Nothing -> mzero + | Set.member fid rec_ = mzero + | otherwise = foldForest (\funid args trees -> do let CncFun fn lins = cncfuns cnc ! funid - args <- mapM (go (Set.insert fcat rec_) fcat) (zip [0..] args) - check_ho_fun fn args + case isLindefCId fn of + Just _ -> do arg <- go (Set.insert fid rec_) scope (head args) mb_tty + return (mkAbs arg) + Nothing -> do tty_fn <- runTcM abs fid (lookupFunType fn) + (e,tty0) <- foldM (\(e1,tty) arg -> goArg (Set.insert fid rec_) scope fid e1 arg tty) + (EFun fn,tty_fn) args + case mb_tty of + Just tty -> runTcM abs fid $ do + i <- newGuardedMeta e + eqType scope (scopeSize scope) i tty tty0 + Nothing -> return () + return (mkAbs e) `mplus` trees) - (\const _ trees -> - return (freeVar const,const) + (\const _ trees -> do + const <- runTcM abs fid $ + case mb_tty of + Just tty -> tcExpr scope const tty + Nothing -> fmap fst $ infExpr scope const + return (mkAbs const) `mplus` trees) - [] fcat forest + mzero fid forest + where + (scope,mkAbs,mb_tty) = updateScope hypos scope_ id mb_tty_ - check_ho_fun fun args - | fun == _V = return (head args) - | fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args)) - | otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args) - - mkVar (EFun v) = v - mkVar (EMeta _) = wildCId - - freeVar (EFun v) = Set.singleton v - freeVar _ = Set.empty + goArg rec_ scope fid e1 arg (TTyp delta (DTyp ((bt,x,ty):hs) c es)) = do + e2' <- go rec_ scope arg (Just (TTyp delta ty)) + let e2 = case bt of + Explicit -> e2' + Implicit -> EImplArg e2' + if x == wildCId + then return (EApp e1 e2,TTyp delta (DTyp hs c es)) + else do v2 <- runTcM abs fid (eval (scopeEnv scope) e2') + return (EApp e1 e2,TTyp (v2:delta) (DTyp hs c es)) + + updateScope [] scope mkAbs mb_tty = (scope,mkAbs,mb_tty) + updateScope ((fid,_):hypos) scope mkAbs mb_tty = + case mb_tty of + Just (TTyp delta (DTyp ((bt,y,ty):hs) c es)) -> + if y == wildCId + then updateScope hypos (addScopedVar x (TTyp delta ty) scope) + (mkAbs . EAbs bt x) + (Just (TTyp delta (DTyp hs c es))) + else updateScope hypos (addScopedVar x (TTyp delta ty) scope) + (mkAbs . EAbs bt x) + (Just (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es))) + Nothing -> (scope,mkAbs,Nothing) + where + (x:_) | fid == fidVar = [wildCId] + | otherwise = [x | PConst _ (EFun x) _ <- maybe [] Set.toList (IntMap.lookup fid forest)] -foldForest :: (FunId -> [FId] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b +newtype TcFM a = TcFM {unTcFM :: MetaStore -> ([(MetaStore,a)],[(FId,TcError)])} + +instance Functor TcFM where + fmap f g = TcFM (\ms -> let (res_g,err_g) = unTcFM g ms + in ([(ms,f x) | (ms,x) <- res_g],err_g)) + +instance Monad TcFM where + return x = TcFM (\ms -> ([(ms,x)],[])) + f >>= g = TcFM (\ms -> case unTcFM f ms of + (res,err) -> let (res',err') = unzip [unTcFM (g x) ms | (ms,x) <- res] + in (concat res',concat (err:err'))) + +instance MonadPlus TcFM where + mzero = TcFM (\ms -> ([],[])) + mplus f g = TcFM (\ms -> let (res_f,err_f) = unTcFM f ms + (res_g,err_g) = unTcFM g ms + in (res_f++res_g,err_f++err_g)) + +runTcM :: Abstr -> FId -> TcM a -> TcFM a +runTcM abstr fid f = TcFM (\ms -> case unTcM f abstr ms of + Ok ms x -> ([(ms,x)],[] ) + Fail err -> ([], [(fid,err)])) + +foldForest :: (FunId -> [PArg] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FId -> IntMap.IntMap (Set.Set Production) -> b foldForest f g b fcat forest = case IntMap.lookup fcat forest of Nothing -> b diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index 84b1b116f..1daeb50f6 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -23,7 +23,7 @@ import qualified Data.Set as Set -- | Linearizes given expression as string in the language linearize :: PGF -> Language -> Tree -> String -linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn "" . (!0)) . linTree pgf lang +linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn "" . firstLin) . linTree pgf lang -- | The same as 'linearizeAllLang' but does not return -- the language. @@ -37,101 +37,86 @@ linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concre -- | Linearizes given expression as a bracketed string in the language bracketedLinearize :: PGF -> Language -> Tree -> BracketedString -bracketedLinearize pgf lang = head . concat . map (snd . untokn "" . (!0)) . linTree pgf lang +bracketedLinearize pgf lang = head . concat . map (snd . untokn "" . firstLin) . linTree pgf lang where head [] = error "cannot linearize" head (bs:bss) = bs +firstLin (_,arr) + | inRange (bounds arr) 0 = arr ! 0 + | otherwise = LeafKS [] + -- | Creates a table from feature name to linearization. -- The outher list encodes the variations tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]] -tabularLinearizes pgf lang e = map (zip lbls . map (unwords . concatMap flattenBracketedString . snd . untokn "") . elems) - (linTree pgf lang e) +tabularLinearizes pgf lang e = map cnv (linTree pgf lang e) where - lbls = case unApp e of - Just (f,_) -> let cat = valCat (lookType pgf f) - in case Map.lookup cat (cnccats (lookConcr pgf lang)) of - Just (CncCat _ _ lbls) -> elems lbls - Nothing -> error "No labels" - Nothing -> error "Not function application" + cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn "") (elems lin) + + lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of + Just (CncCat _ _ lbls) -> elems lbls + Nothing -> error "No labels" -------------------------------------------------------------------- -- Implementation -------------------------------------------------------------------- -type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id - -linTree :: PGF -> Language -> Expr -> [Array LIndex BracketedTokn] +linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)] linTree pgf lang e = - nub [amapWithIndex (\label -> Bracket_ cat fid label [e]) lin | (_,((cat,fid),e,lin)) <- lin0 [] [] Nothing 0 e e] + nub [(ct,amapWithIndex (\label -> Bracket_ cat fid label es) lin) | (_,(ct@(cat,fid),es,(xs,lin))) <- lin Nothing 0 e [] [] e []] where cnc = lookMap (error "no lang") lang (concretes pgf) lp = lproductions cnc - - lin0 xs ys mb_cty n_fid e0 (EAbs _ x e) = lin0 (showCId x:xs) ys mb_cty n_fid e0 e - lin0 xs ys mb_cty n_fid e0 (ETyped e _) = lin0 xs ys mb_cty n_fid e0 e - lin0 xs ys mb_cty n_fid e0 e | null xs = lin ys mb_cty n_fid e0 e [] - | otherwise = apply (xs ++ ys) mb_cty n_fid e0 _B (e:[ELit (LStr x) | x <- xs]) - lin xs mb_cty n_fid e0 (EApp e1 e2) es = lin xs mb_cty n_fid e0 e1 (e2:es) - lin xs mb_cty n_fid e0 (ELit l) [] = case l of - LStr s -> return (n_fid+1,((cidString,n_fid),e0,ss s)) - LInt n -> return (n_fid+1,((cidInt, n_fid),e0,ss (show n))) - LFlt f -> return (n_fid+1,((cidFloat, n_fid),e0,ss (show f))) - lin xs mb_cty n_fid e0 (EMeta i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr ('?':show i)):es) - lin xs mb_cty n_fid e0 (EFun f) es = apply xs mb_cty n_fid e0 f es - lin xs mb_cty n_fid e0 (EVar i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr (xs !! i)) :es) - lin xs mb_cty n_fid e0 (ETyped e _) es = lin xs mb_cty n_fid e0 e es - lin xs mb_cty n_fid e0 (EImplArg e) es = lin xs mb_cty n_fid e0 e es + lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es + lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es) + lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es + lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es + lin mb_cty n_fid e0 ys xs (EFun f) es = apply mb_cty n_fid e0 ys xs f es + lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i) + lin mb_cty n_fid e0 ys xs (EVar i) [] = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i)) + lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of + LStr s -> return (n_fid+1,((cidString,n_fid),[e0],([],ss s))) + LInt n -> return (n_fid+1,((cidInt, n_fid),[e0],([],ss (show n)))) + LFlt f -> return (n_fid+1,((cidFloat, n_fid),[e0],([],ss (show f)))) ss s = listArray (0,0) [[LeafKS [s]]] - apply :: [String] -> Maybe CncType -> FId -> Expr -> CId -> [Expr] -> [(FId,(CncType, Expr, LinTable))] - apply xs mb_cty n_fid e0 f es = + apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, [Expr], LinTable))] + apply mb_cty n_fid e0 ys xs f es = case Map.lookup f lp of Just prods -> do (funid,(cat,fid),ctys) <- getApps prods - guard (length ctys == length es) (n_fid,args) <- descend n_fid (zip ctys es) - let (CncFun _ lins) = cncfuns cnc ! funid - return (n_fid+1,((cat,n_fid),e0,listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])) - Nothing -> apply xs mb_cty n_fid e0 _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin + return (n_fid+1,((cat,n_fid),[e0],mkLinTable cnc (const True) xs funid args)) + Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin where getApps prods = case mb_cty of - Just cty@(cat,fid) -> maybe [] (concatMap (toApp cty) . Set.toList) (IntMap.lookup fid prods) - Nothing | f == _B - || f == _V -> [] - | otherwise -> concat [toApp (wildCId,fid) prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] + Just (cat,fid) -> maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods) + Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] where - toApp cty (PApply funid fids) - | f == _V = [(funid,cty,zip ( repeat cidVar) fids)] - | f == _B = [(funid,cty,zip (fst cty : repeat cidVar) fids)] - | otherwise = let Just (ty,_,_) = Map.lookup f (funs (abstract pgf)) - (args,res) = catSkeleton ty - in [(funid,(res,snd cty),zip args fids)] - toApp cty (PCoerce fid) = concatMap (toApp cty) (maybe [] Set.toList (IntMap.lookup fid prods)) + toApp fid (PApply funid pargs) = + 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) = + maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods) - descend n_fid [] = return (n_fid,[]) - descend n_fid (((cat,fid),e):fes) = do (n_fid,arg) <- lin0 [] xs (Just (cat,fid)) n_fid e e - (n_fid,args) <- descend n_fid fes - return (n_fid,arg:args) + descend n_fid [] = return (n_fid,[]) + descend n_fid ((cty,e):fes) = do (n_fid,arg) <- lin (Just cty) n_fid e (xs++ys) [] e [] + (n_fid,args) <- descend n_fid fes + return (n_fid,arg:args) - computeSeq :: SeqId -> [(CncType,Expr,LinTable)] -> [BracketedTokn] - computeSeq seqid args = concatMap compute (elems seq) - where - seq = sequences cnc ! seqid - - compute (SymCat d r) = getArg d r - compute (SymLit d r) = getArg d r - compute (SymKS ts) = [LeafKS ts] - compute (SymKP ts alts) = [LeafKP ts alts] - - getArg d r - | not (null arg_lin) = [Bracket_ cat fid r [e] arg_lin] - | otherwise = arg_lin - where - arg_lin = lin ! r - ((cat,fid),e,lin) = args !! d + def (Just (cat,fid)) n_fid e0 ys xs s = + case IntMap.lookup fid (lindefs cnc) of + Just funs -> do funid <- funs + let args = [((wildCId, n_fid),[e0],([],ss s))] + return (n_fid+2,((cat,n_fid+1),[e0],mkLinTable cnc (const True) xs funid args)) + Nothing + | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),[e0],(xs,listArray (0,0) [[LeafKS [s]]]))) + | otherwise -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc)) + def (Just (cat,fid)) n_fid e0 ys xs s + def Nothing n_fid e0 ys xs s = [] amapWithIndex :: (IArray a e1, IArray a e2, Ix i) => (i -> e1 -> e2) -> a i e1 -> a i e2 amapWithIndex f arr = listArray (bounds arr) (map (uncurry f) (assocs arr)) diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 95bc82aef..ae984cfdf 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -10,6 +10,7 @@ import qualified Data.IntSet as IntSet import qualified Data.Array as Array import Data.Maybe import Data.List +import Data.Array.IArray import Text.PrettyPrint -- operations for manipulating PGF grammars and objects @@ -132,9 +133,6 @@ cidInt = mkCId "Int" cidFloat = mkCId "Float" cidVar = mkCId "__gfVar" -_B = mkCId "__gfB" -_V = mkCId "__gfV" - -- Utilities for doing linearization @@ -162,7 +160,7 @@ data BracketedTokn | Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex [Expr] [BracketedTokn] -- Invariant: the list is not empty deriving Eq -type LinTable = Array.Array LIndex [BracketedTokn] +type LinTable = ([CId],Array.Array LIndex [BracketedTokn]) -- | Renders the bracketed string as string where -- the brackets are shown as @(S ...)@ where @@ -191,6 +189,34 @@ untokn nw (Bracket_ cat fid index es bss) = let (nw',bss') = mapAccumR untokn nw bss in (nw',[Bracket cat fid index es (concat bss')]) +type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id + +mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,[Expr],LinTable)] -> LinTable +mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq filter (elems (sequences cnc ! seqid)) args | seqid <- elems lins]) + where + (CncFun _ lins) = cncfuns cnc ! funid + +computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,[Expr],LinTable)] -> [BracketedTokn] +computeSeq filter seq args = concatMap compute seq + where + compute (SymCat d r) = getArg d r + compute (SymLit d r) = getArg d r + compute (SymVar d r) = getVar d r + compute (SymKS ts) = [LeafKS ts] + compute (SymKP ts alts) = [LeafKP ts alts] + + getArg d r + | not (null arg_lin) && + filter ct = [Bracket_ cat fid r es arg_lin] + | otherwise = arg_lin + where + arg_lin = lin ! r + (ct@(cat,fid),es,(xs,lin)) = args !! d + + getVar d r = [LeafKS [showCId (xs !! r)]] + where + (ct,es,(xs,lin)) = args !! d + flattenBracketedString :: BracketedString -> [String] flattenBracketedString (Leaf w) = [w] flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs index f8e089830..d5b9230b4 100644 --- a/src/runtime/haskell/PGF/Optimize.hs +++ b/src/runtime/haskell/PGF/Optimize.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module PGF.Optimize ( optimizePGF , updateProductionIndices @@ -16,6 +17,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap +import qualified Data.List as List import Control.Monad.ST import GF.Data.Utilities(sortNub) @@ -29,14 +31,20 @@ updateProductionIndices pgf = pgf{concretes = fmap (updateConcrete (abstract pgf topDownFilter :: CId -> Concr -> Concr topDownFilter startCat cnc = - let ((seqs,funs),prods) = IntMap.mapAccumWithKey (\env res set -> mapAccumLSet (optimize res) env set) - (Map.empty,Map.empty) - (productions cnc) + let env0 = (Map.empty,Map.empty) + (env1,defs) = IntMap.mapAccumWithKey (\env fid funids -> mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids) + env0 + (lindefs cnc) + (env2,prods) = IntMap.mapAccumWithKey (\env fid set -> mapAccumLSet (optimizeProd fid) env set) + env1 + (productions cnc) cats = Map.mapWithKey filterCatLabels (cnccats cnc) + (seqs,funs) = env2 in cnc{ sequences = mkSetArray seqs , cncfuns = mkSetArray funs , productions = prods , cnccats = cats + , lindefs = defs } where fid2cat fid = @@ -46,8 +54,8 @@ topDownFilter startCat cnc = (fid:_) -> fid2cat fid _ -> error "unknown forest id" where - fid2catMap = IntMap.fromList [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc), - fid <- [start..end]] + fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc), + fid <- [start..end]]) starts = case Map.lookup startCat (cnccats cnc) of @@ -64,11 +72,11 @@ topDownFilter startCat cnc = CncFun _ lin = cncfuns cnc ! funid rel fid _ = Map.empty - deps args seqid = Set.fromList [(fid2cat (args !! r),d) | SymCat r d <- elems seq] + deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- elems seq] where seq = sequences cnc ! seqid - -- here we create a mapping from category to an array of indices. + -- here we create a mapping from a category to an array of indices. -- An element of the array is equal to -1 if the corresponding index -- is not going to be used in the optimized grammar, or the new index -- if it will be used @@ -122,11 +130,16 @@ topDownFilter startCat cnc = reindex indices (i+1) j (k+1) | otherwise = return () - optimize res (seqs,funs) (PApply funid args) = + optimizeProd res env (PApply funid args) = + let (env',funid') = optimizeFun res args env funid + in (env', PApply funid' args) + optimizeProd res env prod = (env,prod) + + optimizeFun res args (seqs,funs) funid = let (seqs',lin') = mapAccumL addUnique seqs [amap updateSymbol (sequences cnc ! seqid) | (lbl,seqid) <- assocs lin, indicesOf res ! lbl >= 0] (funs',funid') = addUnique funs (CncFun fun (mkArray lin')) - in ((seqs',funs'), PApply funid' args) + in ((seqs',funs'), funid') where CncFun fun lin = cncfuns cnc ! funid @@ -140,11 +153,10 @@ topDownFilter startCat cnc = Just seqid -> (seqs,seqid) Nothing -> let seqid = Map.size seqs in (Map.insert seq seqid seqs, seqid) - - updateSymbol (SymCat r d) = SymCat r (indicesOf (args !! r) ! d) + + updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid ! d) updateSymbol s = s - optimize res env prod = (env,prod) - + filterCatLabels cat (CncCat start end lbls) = case Map.lookup cat closure of Just indices -> let lbls' = mkArray [lbl | (i,lbl) <- assocs lbls, indices ! i >= 0] @@ -159,50 +171,35 @@ topDownFilter startCat cnc = bottomUpFilter :: Concr -> Concr -bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty (productions cnc)} +bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty IntSet.empty (productions cnc)} -filterProductions prods0 prods +filterProductions prods0 hoc0 prods | prods0 == prods1 = prods0 - | otherwise = filterProductions prods1 prods + | otherwise = filterProductions prods1 hoc1 prods where - prods1 = IntMap.unionWith Set.union prods0 (IntMap.mapMaybe (filterProdSet prods0) prods) + (prods1,hoc1) = IntMap.foldWithKey foldProdSet (IntMap.empty,IntSet.empty) prods - filterProdSet prods0 set - | Set.null set1 = Nothing - | otherwise = Just set1 + foldProdSet fid set (!prods,!hoc) + | Set.null set1 = (prods,hoc) + | otherwise = (IntMap.insert fid set1 prods,hoc1) where - set1 = Set.filter (filterRule prods0) set + set1 = Set.filter filterRule set + hoc1 = Set.fold accumHOC hoc set1 - filterRule prods0 (PApply funid args) = all (\fid -> isPredefFId fid || IntMap.member fid prods0) args - filterRule prods0 (PCoerce fid) = isPredefFId fid || IntMap.member fid prods0 - filterRule prods0 _ = True + filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args + filterRule (PCoerce fid) = isLive fid + filterRule _ = True + + isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0 + + accumHOC (PApply funid args) hoc = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc (_,fid) -> IntSet.insert fid hoc) hoc hypos) hoc args + accumHOC _ hoc = hoc updateConcrete abs cnc = - let p_prods = (filterProductions IntMap.empty . parseIndex cnc) (productions cnc) - l_prods = (linIndex cnc . filterProductions IntMap.empty) (productions cnc) + let p_prods = filterProductions IntMap.empty IntSet.empty (productions cnc) + l_prods = linIndex cnc p_prods in cnc{pproductions = p_prods, lproductions = l_prods} where - parseIndex cnc = IntMap.mapMaybeWithKey filterProdSet - where - filterProdSet fid prods - | fid `IntSet.member` ho_fids = Just prods - | otherwise = let prods' = Set.filter (not . is_ho_prod) prods - in if Set.null prods' - then Nothing - else Just prods' - - is_ho_prod (PApply _ [fid]) | fid == fidVar = True - is_ho_prod _ = False - - ho_fids :: IntSet.IntSet - ho_fids = IntSet.fromList [fid | cat <- ho_cats - , fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats cnc))] - - ho_cats :: [CId] - ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs abs) - , h <- case ty of {DTyp hyps val _ -> hyps} - , c <- fst (catSkeleton (typeOfHypo h))] - linIndex cnc productions = Map.fromListWith (IntMap.unionWith Set.union) [(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs index 4b8056009..3ed3d7a72 100644 --- a/src/runtime/haskell/PGF/Parse.hs +++ b/src/runtime/haskell/PGF/Parse.hs @@ -28,7 +28,7 @@ import PGF.Data import PGF.Expr(Tree) import PGF.Macros import PGF.TypeCheck -import PGF.Forest(Forest(Forest), linearizeWithBrackets, foldForest) +import PGF.Forest(Forest(Forest), linearizeWithBrackets, getAbsTrees, foldForest) -- | The input to the parser is a pair of predicates. The first one -- 'piToken' checks that a given token, suggested by the grammar, @@ -50,6 +50,7 @@ data ParseOutput -- if there are many analizes for some phrase but they all are not type correct. | ParseOk [Tree] -- ^ If the parsing and the type checkeing are successful we get a list of abstract syntax trees. -- The list should be non-empty. + | ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced parse :: PGF -> Language -> Type -> [Token] -> (ParseOutput,BracketedString) parse pgf lang typ toks = loop (initState pgf lang typ) toks @@ -108,7 +109,7 @@ simpleParseInput t = ParseInput (==t) (matchLit t) _ -> Nothing } | fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]); _ -> Nothing } - | fid == fidVar = Just (cidVar,EFun (mkCId t),[t]) + | fid == fidVar = Just (wildCId,EFun (mkCId t),[t]) | otherwise = Nothing mkParseInput :: PGF -> Language -> (a -> Token -> Bool) -> [(CId,a -> Maybe (Tree,[Token]))] -> a -> ParseInput @@ -140,7 +141,7 @@ nextState (PState pgf cnc chart items) input = let (mb_agenda,map_items) = TMap.decompose items agenda = maybe [] Set.toList mb_agenda acc = TMap.unions [tmap | (t,tmap) <- Map.toList map_items, piToken input t] - (acc1,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart + (acc1,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda acc chart chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 , passive=emptyPC @@ -166,7 +167,7 @@ getCompletions (PState pgf cnc chart items) w = let (mb_agenda,map_items) = TMap.decompose items agenda = maybe [] Set.toList mb_agenda acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items - (acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart + (acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda acc chart chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 , passive=emptyPC @@ -184,7 +185,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState) recoveryStates open_types (EState pgf cnc chart) = let open_fcats = concatMap type2fcats open_types agenda = foldl (complete open_fcats) [] (actives chart) - (acc,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda Map.empty chart + (acc,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda Map.empty chart chart2 = chart1{ active =emptyAC , actives=active chart1 : actives chart1 , passive=emptyPC @@ -200,7 +201,7 @@ recoveryStates open_types (EState pgf cnc chart) = foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> (:) (Active j' (ppos+1) funid seqid args keyc))) items - [set | fcat <- open_fcats, set <- lookupACByFCat fcat ac] + [set | fcat <- open_fcats, (set,_) <- lookupACByFCat fcat ac] flit _ = Nothing ftok (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc @@ -212,26 +213,24 @@ recoveryStates open_types (EState pgf cnc chart) = getParseOutput :: ParseState -> Type -> (ParseOutput,BracketedString) getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) = let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq - | otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots] + | otherwise = [([SymCat 0 lbl],[PArg [] fid]) | AK fid lbl <- roots] - bs = linearizeWithBrackets (Forest (abstract pgf) cnc (forest chart1) froots) - - exps = nubsort $ do - (AK fid lbl) <- roots - (fvs,e) <- go Set.empty 0 (0,fid) - guard (Set.null fvs) - Right e1 <- [checkExpr pgf e ty] - return e1 - - res = if null exps - then ParseFailed (offset chart) - else ParseOk exps + f = Forest (abstract pgf) cnc (forest chart1) froots + + bs = linearizeWithBrackets f + + res | not (null es) = ParseOk es + | not (null errs) = TypeError errs + | otherwise = ParseIncomplete + where xs = [getAbsTrees f (PArg [] fid) (Just ty) | (AK fid lbl) <- roots] + es = concat [es | Right es <- xs] + errs = concat [errs | Left errs <- xs] in (res,bs) where (mb_agenda,acc) = TMap.decompose items agenda = maybe [] Set.toList mb_agenda - (acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda (TMap.compose Nothing acc) chart + (acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda (TMap.compose Nothing acc) chart seq = [(j,cutAt ppos toks seqid,args,key) | (toks,set) <- TMap.toList acc', Active j ppos funid seqid args key <- Set.toList set] flit _ = Nothing @@ -255,32 +254,6 @@ getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) = return (AK fid lbl) Nothing -> mzero - go rec_ fcat' (d,fcat) - | fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments - | Set.member fcat rec_ = mzero - | otherwise = foldForest (\funid args trees -> - do let CncFun fn lins = cncfuns cnc ! funid - args <- mapM (go (Set.insert fcat rec_) fcat) (zip [0..] args) - check_ho_fun fn args - `mplus` - trees) - (\const _ trees -> - return (freeVar const,const) - `mplus` - trees) - [] fcat (forest chart1) - - check_ho_fun fun args - | fun == _V = return (head args) - | fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args)) - | otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args) - - mkVar (EFun v) = v - mkVar (EMeta _) = wildCId - - freeVar (EFun v) = Set.singleton v - freeVar _ = Set.empty - getPartialSeq seqs actives = expand Set.empty where expand acc [] = @@ -291,72 +264,99 @@ getPartialSeq seqs actives = expand Set.empty where acc' = Set.insert item acc items' = case lookupAC key (actives !! j) of - Nothing -> items - Just set -> [if j' < j - then let lin' = take ppos (elems (unsafeAt seqs seqid)) - in (j',lin'++map (inc (length args')) lin,args'++args,key') - else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items + Nothing -> items + Just (set,_) -> [if j' < j + then let lin' = take ppos (elems (unsafeAt seqs seqid)) + in (j',lin'++map (inc (length args')) lin,args'++args,key') + else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items inc n (SymCat d r) = SymCat (n+d) r + inc n (SymVar d r) = SymVar (n+d) r inc n (SymLit d r) = SymLit (n+d) r inc n s = s -process flit ftok !seqs !funs [] acc chart = (acc,chart) -process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart +process flit ftok !seqs !funs defs [] acc chart = (acc,chart) +process flit ftok !seqs !funs defs (item@(Active j ppos funid seqid args key0):items) acc chart | inRange (bounds lin) ppos = case unsafeAt lin ppos of - SymCat d r -> let !fid = args !! d + SymCat d r -> let PArg hypos !fid = args !! d key = AK fid r - + items2 = case lookupPC (mkPK key k) (passive chart) of Nothing -> items - Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items + Just id -> (Active j (ppos+1) funid seqid (updateAt d (PArg hypos id) args) key0) : items items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items) (\_ _ items -> items) - items2 fid (forest chart) + items2 fid (IntMap.unionWith Set.union new_sc (forest chart)) + + new_sc = foldl uu parent_sc hypos + parent_sc = case lookupAC key0 ((active chart : actives chart) !! (k-j)) of + Nothing -> IntMap.empty + Just (set,sc) -> sc + in case lookupAC key (active chart) of - Nothing -> process flit ftok seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} - Just set | Set.member item set -> process flit ftok seqs funs items acc chart - | otherwise -> process flit ftok seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} + Nothing -> process flit ftok seqs funs defs items3 acc chart{active=insertAC key (Set.singleton item,new_sc) (active chart)} + Just (set,sc) | Set.member item set -> process flit ftok seqs funs defs items acc chart + | otherwise -> process flit ftok seqs funs defs items2 acc chart{active=insertAC key (Set.insert item set,IntMap.unionWith Set.union new_sc sc) (active chart)} SymKS toks -> let !acc' = ftok toks (Active j (ppos+1) funid seqid args key0) acc - in process flit ftok seqs funs items acc' chart + in process flit ftok seqs funs defs items acc' chart SymKP strs vars -> let !acc' = foldl (\acc toks -> ftok toks (Active j (ppos+1) funid seqid args key0) acc) acc (strs:[strs' | Alt strs' _ <- vars]) - in process flit ftok seqs funs items acc' chart - SymLit d r -> let fid = args !! d + in process flit ftok seqs funs defs items acc' chart + SymLit d r -> let PArg hypos fid = args !! d key = AK fid r !fid' = case lookupPC (mkPK key k) (passive chart) of Nothing -> fid Just fid -> fid in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of - (toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc - in process flit ftok seqs funs items acc' chart + (toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc + in process flit ftok seqs funs defs items acc' chart [] -> case flit fid of Just (cat,lit,toks) -> let fid' = nextId chart - !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc - in process flit ftok seqs funs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart) - ,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart) - ,nextId =nextId chart+1 - } - Nothing -> process flit ftok seqs funs items acc chart{active=insertAC key (Set.singleton item) (active chart)} + !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc + in process flit ftok seqs funs defs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart) + ,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart) + ,nextId =nextId chart+1 + } + Nothing -> process flit ftok seqs funs defs items acc chart + SymVar d r -> let PArg hypos fid0 = args !! d + (fid1,fid2) = hypos !! r + key = AK fid1 0 + !fid' = case lookupPC (mkPK key k) (passive chart) of + Nothing -> fid1 + Just fid -> fid + + in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of + (toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc + in process flit ftok seqs funs defs items acc' chart + [] -> case flit fid1 of + Just (cat,lit,toks) + -> let fid' = nextId chart + !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc + in process flit ftok seqs funs defs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart) + ,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart) + ,nextId =nextId chart+1 + } + Nothing -> process flit ftok seqs funs defs items acc chart | otherwise = case lookupPC (mkPK key0 j) (passive chart) of Nothing -> let fid = nextId chart items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of - Nothing -> items - Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> - let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos - in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set - in process flit ftok seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) - ,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart) - ,nextId =nextId chart+1 - } + Nothing -> items + Just (set,sc) -> Set.fold (\(Active j' ppos funid seqid args keyc) -> + let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos + PArg hypos _ = args !! d + in (:) (Active j' (ppos+1) funid seqid (updateAt d (PArg hypos fid) args) keyc)) items set + in process flit ftok seqs funs defs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) + ,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart) + ,nextId =nextId chart+1 + } Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items - in process flit ftok seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)} + in process flit ftok seqs funs defs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)} where !lin = unsafeAt seqs seqid !k = offset chart @@ -367,6 +367,10 @@ process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items) where CncFun _ lins = unsafeAt funs funid + uu forest (fid1,fid2) = + case IntMap.lookup fid2 defs of + Just funs -> foldl (\forest funid -> IntMap.insertWith Set.union fid2 (Set.singleton (PApply funid [PArg [] fid1])) forest) forest funs + Nothing -> forest updateAt :: Int -> a -> [a] -> [a] updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] @@ -381,22 +385,22 @@ data Active {-# UNPACK #-} !DotPos {-# UNPACK #-} !FunId {-# UNPACK #-} !SeqId - [FId] + [PArg] {-# UNPACK #-} !ActiveKey deriving (Eq,Show,Ord) data ActiveKey = AK {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex deriving (Eq,Ord,Show) -type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active)) +type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active, IntMap.IntMap (Set.Set Production))) emptyAC :: ActiveChart emptyAC = IntMap.empty -lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active) +lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active, IntMap.IntMap (Set.Set Production)) lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l -lookupACByFCat :: FId -> ActiveChart -> [Set.Set Active] +lookupACByFCat :: FId -> ActiveChart -> [(Set.Set Active, IntMap.IntMap (Set.Set Production))] lookupACByFCat fcat chart = case IntMap.lookup fcat chart of Nothing -> [] @@ -408,7 +412,7 @@ labelsAC fcat chart = Nothing -> [] Just map -> IntMap.keys map -insertAC :: ActiveKey -> Set.Set Active -> ActiveChart -> ActiveChart +insertAC :: ActiveKey -> (Set.Set Active, IntMap.IntMap (Set.Set Production)) -> ActiveChart -> ActiveChart insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index c10cf365c..ae23b96da 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -46,7 +46,9 @@ ppCnc name cnc = nest 2 (ppAll ppFlag (cflags cnc) $$ text "productions" $$ nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$ - text "functions" $$ + text "lindefs" $$ + nest 2 (vcat (map ppLinDef (IntMap.toList (lindefs cnc)))) $$ + text "lin" $$ nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$ text "sequences" $$ nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$ @@ -56,8 +58,13 @@ ppCnc name cnc = nest 2 (vcat (map ppPrintName (Map.toList (printnames cnc))))) $$ char '}' +ppCncArg :: PArg -> Doc +ppCncArg (PArg hyps fid) + | null hyps = ppFId fid + | otherwise = hsep (map (ppFId . snd) hyps) <+> text "->" <+> ppFId fid + ppProduction (fid,PApply funid args) = - ppFId fid <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFId args))) + ppFId fid <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppCncArg args))) ppProduction (fid,PCoerce arg) = ppFId fid <+> text "->" <+> char '_' <> brackets (ppFId arg) ppProduction (fid,PConst _ _ ss) = @@ -66,6 +73,9 @@ ppProduction (fid,PConst _ _ ss) = ppCncFun (funid,CncFun fun arr) = ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) +ppLinDef (fid,funids) = + ppFId fid <+> text "->" <+> hcat (punctuate comma (map ppFunId funids)) + ppSeq (seqid,seq) = ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq)) @@ -78,6 +88,7 @@ ppPrintName (id,name) = ppSymbol (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>' ppSymbol (SymLit d r) = char '{' <> int d <> comma <> int r <> char '}' +ppSymbol (SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>' ppSymbol (SymKS ts) = ppStrs ts ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts))) diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 1e4d4f2ef..a17392c51 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -11,9 +11,17 @@ -- ----------------------------------------------------------------------------- -module PGF.TypeCheck (checkType, checkExpr, inferExpr, +module PGF.TypeCheck ( checkType, checkExpr, inferExpr - ppTcError, TcError(..) + , ppTcError, TcError(..) + + -- internals needed for the typechecking of forests + , MetaStore, newMeta, newGuardedMeta + , Scope, emptyScope, scopeSize, scopeEnv, addScopedVar + , TcM(..), TcResult(..), TType(..), tcError + , tcExpr, infExpr, eqType + , lookupFunType, eval + , refineExpr, checkResolvedMetaStore ) where import PGF.Data @@ -65,7 +73,7 @@ scopeSize (Scope gamma) = length gamma type MetaStore = IntMap MetaValue data MetaValue - = MUnbound Scope [Expr -> TcM ()] + = MUnbound Scope TType [Expr -> TcM ()] | MBound Expr | MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved -- to unlock this meta variable @@ -96,9 +104,9 @@ lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of Just (ty,_,_) -> Ok ms (TTyp [] ty) Nothing -> Fail (UnknownFun fun)) -newMeta :: Scope -> TcM MetaId -newMeta scope = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 - in Ok (IntMap.insert metaid (MUnbound scope []) ms) metaid) +newMeta :: Scope -> TType -> TcM MetaId +newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 + in Ok (IntMap.insert metaid (MUnbound scope tty []) ms) metaid) newGuardedMeta :: Expr -> TcM MetaId newGuardedMeta e = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 @@ -115,7 +123,7 @@ lookupMeta ms i = Just (MBound t) -> Just t Just (MGuarded t _ x) | x == 0 -> Just t | otherwise -> Nothing - Just (MUnbound _ _) -> Nothing + Just (MUnbound _ _ _) -> Nothing Nothing -> Nothing tcError :: TcError -> TcM a @@ -125,7 +133,7 @@ addConstraint :: MetaId -> MetaId -> Env -> [Value] -> (Value -> TcM ()) -> TcM addConstraint i j env vs c = do mv <- getMeta j case mv of - MUnbound scope cs -> addRef >> setMeta j (MUnbound scope ((\e -> release >> apply env e vs >>= c) : cs)) + MUnbound scope tty cs -> addRef >> setMeta j (MUnbound scope tty ((\e -> release >> apply env e vs >>= c) : cs)) MBound e -> apply env e vs >>= c MGuarded e cs x | x == 0 -> apply env e vs >>= c | otherwise -> addRef >> setMeta j (MGuarded e ((\e -> release >> apply env e vs >>= c) : cs) x) @@ -162,6 +170,8 @@ data TcError | CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression. | UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking. | UnexpectedImplArg [CId] Expr -- ^ Implicit argument was passed where the type doesn't allow it + | UnsolvableGoal [CId] MetaId Type -- ^ There is a goal that cannot be solved + deriving Eq -- | Renders the type checking error to a document. See 'Text.PrettyPrint'. ppTcError :: TcError -> Doc @@ -177,6 +187,8 @@ ppTcError (CannotInferType xs e) = text "Cannot infer the type of expressi ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$ text "in the expression:" <+> ppExpr 0 xs e ppTcError (UnexpectedImplArg xs e) = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here" +ppTcError (UnsolvableGoal xs metaid ty)= text "The goal:" <+> ppMeta metaid <+> colon <+> ppType 0 xs ty $$ + text "cannot be solved" ----------------------------------------------------- -- checkType @@ -223,7 +235,7 @@ tcCatArgs scope (EImplArg e:es) delta ((Implicit,x,ty):hs) ty0 n m = do tcCatArgs scope es (v:delta) hs ty0 n m return (delta,EImplArg e:es) tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do - i <- newMeta scope + i <- newMeta scope (TTyp delta ty) (delta,es) <- if x == wildCId then tcCatArgs scope es delta hs ty0 n m else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : delta) hs ty0 n m @@ -281,7 +293,7 @@ tcExpr scope e0@(EAbs Explicit x e) tty = _ -> do ty <- evalType (scopeSize scope) tty tcError (NotFunType (scopeVars scope) e0 ty) tcExpr scope (EMeta _) tty = do - i <- newMeta scope + i <- newMeta scope tty return (EMeta i) tcExpr scope e0 tty = do (e0,tty0) <- infExpr scope e0 @@ -352,7 +364,7 @@ tcArg scope e1 e2 delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = do else do v2 <- eval (scopeEnv scope) e2 return (EApp e1 e2,v2:delta,DTyp hs c es) tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do - i <- newMeta scope + i <- newMeta scope (TTyp delta ty) if x == wildCId then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es) else tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 (VMeta i (scopeEnv scope) [] : delta) (DTyp hs c es) @@ -402,7 +414,7 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 MBound e -> apply env e vs MGuarded e _ x | x == 0 -> apply env e vs | otherwise -> return v - MUnbound _ _ -> return v + MUnbound _ _ _ -> return v deRef v = return v eqValue' k (VSusp i env vs1 c) v2 = addConstraint i0 i env vs1 (\v1 -> eqValue k (c v1) v2) @@ -410,15 +422,15 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 eqValue' k (VMeta i env1 vs1) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2 eqValue' k (VMeta i env1 vs1) v2 = do mv <- getMeta i case mv of - MUnbound scopei cs -> do e2 <- mkLam i scopei env1 vs1 v2 - setMeta i (MBound e2) - sequence_ [c e2 | c <- cs] - MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env1 e vs1 >>= \v1 -> eqValue' k v1 v2) : cs) x) + MUnbound scopei _ cs -> do e2 <- mkLam i scopei env1 vs1 v2 + setMeta i (MBound e2) + sequence_ [c e2 | c <- cs] + MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env1 e vs1 >>= \v1 -> eqValue' k v1 v2) : cs) x) eqValue' k v1 (VMeta i env2 vs2) = do mv <- getMeta i case mv of - MUnbound scopei cs -> do e1 <- mkLam i scopei env2 vs2 v1 - setMeta i (MBound e1) - sequence_ [c e1 | c <- cs] + MUnbound scopei _ cs -> do e1 <- mkLam i scopei env2 vs2 v1 + setMeta i (MBound e1) + sequence_ [c e1 | c <- cs] MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env2 e vs2 >>= \v2 -> eqValue' k v1 v2) : cs) x) eqValue' k (VApp f1 vs1) (VApp f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2 eqValue' k (VConst f1 vs1) (VConst f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2 @@ -452,11 +464,11 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 else return () mv <- getMeta i case mv of - MBound e -> apply env e vs >>= occurCheck i0 k xs - MGuarded e _ _ -> apply env e vs >>= occurCheck i0 k xs - MUnbound scopei _ | scopeSize scopei > k -> raiseTypeMatchError - | otherwise -> do vs <- mapM (occurCheck i0 k xs) vs - return (VMeta i env vs) + MBound e -> apply env e vs >>= occurCheck i0 k xs + MGuarded e _ _ -> apply env e vs >>= occurCheck i0 k xs + MUnbound scopei _ _ | scopeSize scopei > k -> raiseTypeMatchError + | otherwise -> do vs <- mapM (occurCheck i0 k xs) vs + return (VMeta i env vs) occurCheck i0 k xs (VSusp i env vs cnt) = do addConstraint i0 i env vs (\v -> occurCheck i0 k xs (cnt v) >> return ()) return (VSusp i env vs cnt) occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of @@ -480,7 +492,7 @@ checkResolvedMetaStore scope e = TcM (\abstr ms -> then Ok ms () else Fail (UnresolvedMetaVars (scopeVars scope) e xs)) where - isResolved (MUnbound _ []) = True + isResolved (MUnbound _ _ []) = True isResolved (MGuarded _ _ _) = True isResolved (MBound _) = True isResolved _ = False diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 226fc5fa8..0597c1c52 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -28,7 +28,7 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId) import PGF.Data import PGF.Expr (showExpr, Tree) import PGF.Linearize -import PGF.Macros (lookValCat, lookMap, _B, _V, +import PGF.Macros (lookValCat, lookMap, BracketedString(..), BracketedTokn(..), flattenBracketedString) import qualified Data.Map as Map @@ -286,17 +286,14 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e lin0 path xs ys mb_fid (EAbs _ x e) = lin0 path (showCId x:xs) ys mb_fid e lin0 path xs ys mb_fid (ETyped e _) = lin0 path xs ys mb_fid e - lin0 path xs ys mb_fid e | null xs = lin path ys mb_fid e [] - | otherwise = apply path (xs ++ ys) mb_fid _B (e:[ELit (LStr x) | x <- xs]) + lin0 path xs ys mb_fid e = lin path ys mb_fid e [] lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es) lin path xs mb_fid (ELit l) [] = case l of LStr s -> return (mark Nothing path (ss s)) LInt n -> return (mark Nothing path (ss (show n))) LFlt f -> return (mark Nothing path (ss (show f))) - lin path xs mb_fid (EMeta i) es = apply path xs mb_fid _V (ELit (LStr ('?':show i)):es) lin path xs mb_fid (EFun f) es = map (mark (Just f) path) (apply path xs mb_fid f es) - lin path xs mb_fid (EVar i) es = apply path xs mb_fid _V (ELit (LStr (xs !! i)) :es) lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es @@ -308,21 +305,16 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e Just set -> do prod <- Set.toList set case prod of PApply funid fids -> do guard (length fids == length es) - args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es) + args <- sequence (zipWith3 (\i (PArg _ fid) e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es) let (CncFun _ lins) = cncfuns cnc ! funid return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]) PCoerce fid -> apply path xs (Just fid) f es Nothing -> mzero - Nothing -> apply path xs mb_fid _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin where lookupProds (Just fid) prods = IntMap.lookup fid prods - lookupProds Nothing prods - | f == _B || f == _V = Nothing - | otherwise = Just (Set.filter isApp (Set.unions (IntMap.elems prods))) + lookupProds Nothing prods = Just (Set.filter isApp (Set.unions (IntMap.elems prods))) - sub i path - | f == _B || f == _V = path - | otherwise = i:path + sub i path = i:path isApp (PApply _ _) = True isApp _ = False diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index dae25c567..c19f7961c 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -135,6 +135,7 @@ doTranslate pgf input mcat mfrom mto = | (to,output) <- linearizeAndBind pgf mto tree] )] | tree <- trees])] + jsonParseOutput (PGF.ParseIncomplete)= [] jsonParseOutput (PGF.ParseFailed _) = [] jsonParseOutput (PGF.TypeError errs) = [("typeErrors",showJSON [toJSObject [("fid", showJSON fid) ,("msg", showJSON (show (PGF.ppTcError err)))