GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 19:22:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

native representation for HOAS in PMCFG and incremental type checking of the parse forest

Browse Source
This commit is contained in:
krasimir
2010-08-09 10:10:08 +00:00
parent 68d04c9136
commit b0e110cf4f
17 changed files with 544 additions and 436 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -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):" $$ TypeError errs -> ([], render (text "The parsing is successful but the type checking failed with error(s):" $$
nest 2 (vcat (map (ppTcError . snd) errs))) nest 2 (vcat (map (ppTcError . snd) errs)))
++ "\n" ++ msg) ++ "\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) ++ "\n" ++ msg)
ParseIncomplete-> ([], "The sentence is not complete")
where where
(es,msg) = fromParse opts ps (es,msg) = fromParse opts ps

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

@@ -51,6 +51,8 @@ convertFile conf src file = do
return ws return ws
TypeError _ -> TypeError _ ->
return [] return []
ParseIncomplete ->
return []
ParseOk ts -> ParseOk ts ->
case rank ts of case rank ts of
(t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >> (t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >>

241
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -44,21 +44,26 @@ import Control.Exception
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
convertConcrete opts0 gr am cm = do convertConcrete opts0 gr am cm = do
let env0 = emptyGrammarEnv gr cm let env = emptyGrammarEnv gr cm
when (flag optProf opts) $ do when (flag optProf opts) $ do
profileGrammar cm env0 pfrules profileGrammar cm env pfrules
env1 <- expandHOAS opts cm env0 env <- foldM (convertLinDef gr opts) env pflindefs
env2 <- foldM (convertRule gr opts) env1 pfrules env <- foldM (convertRule gr opts) env pfrules
return $ getConcr flags printnames env2 return $ getConcr flags printnames env
where where
(m,mo) = cm (m,mo) = cm
opts = addOptions (M.flags (snd am)) opts0 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 = [ 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), (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)] 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 :: Ident -> CId
i2i = CId . ident2bs 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 ""
hPutStrLn stderr ("Language: " ++ showIdent m) hPutStrLn stderr ("Language: " ++ showIdent m)
hPutStrLn stderr "" hPutStrLn stderr ""
hPutStrLn stderr "Categories Count" hPutStrLn stderr "Categories Count"
hPutStrLn stderr "--------------------------------" hPutStrLn stderr "--------------------------------"
case IntMap.lookup 0 catSet of mapM_ profileCat (Map.toList catSet)
Just cats -> mapM_ profileCat (Map.toList cats)
Nothing -> return ()
hPutStrLn stderr "--------------------------------" hPutStrLn stderr "--------------------------------"
hPutStrLn stderr "" hPutStrLn stderr ""
hPutStrLn stderr "Rules Count" 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 let pargs = map (protoFCat env) args
hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args)))) hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
where where
catFactor (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of case Map.lookup cat catSet of
Just (s,e,_) -> e-s+1 Just (s,e,_) -> e-s+1
Nothing -> 0 Nothing -> 0
@@ -109,12 +112,40 @@ profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSe
rformat :: Int -> String -> String rformat :: Int -> String -> String
rformat n s = replicate (n-length s) ' ' ++ s rformat n s = replicate (n-length s) ' ' ++ s
data ProtoFRule = PFRule Ident {- function -} data ProtoFRule = PFRule Ident {- function -}
[(Int,Cat)] {- argument types: context size and category -} [([Cat],Cat)] {- argument types: context size and category -}
(Int,Cat) {- result type : context size (always 0) and category -} ([Cat],Cat) {- result type : context size (always 0) and category -}
[Type] {- argument lin-types representation -} [Type] {- argument lin-types representation -}
Type {- result lin-type representation -} Type {- result lin-type representation -}
Term {- body -} 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 :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do 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,[]) b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
(grammarEnv1,b1) = addSequencesB grammarEnv b (grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule grammarEnv2 = foldBM addRule
grammarEnv grammarEnv1
(goB b1 CNil []) (goB b1 CNil [])
(pres,pargs) ) grammarEnv1 (pres,pargs)
grammarEnv3 = optimize pargs grammarEnv2
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun) when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
return $! grammarEnv2 return $! grammarEnv3
where where
addRule lins (newCat', newArgs') env0 = addRule lins (newCat', newArgs') env0 =
let [newCat] = getFIds env0 newCat' 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)) (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) convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv
brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do
case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of let pres = protoFCat grammarEnv ([],cat)
(GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 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 where
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | PApply funid args <- Set.toList ps]) lindefCId = mkCId ("lindef "++showIdent (snd cat))
where
ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv addRule lins (newCat', newArgs') env0 =
ff funid xs env let [newCat] = getFIds env0 newCat'
| product (map Set.size ys) == count = (env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins))
case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of in addLinDef env1 newCat funid
(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
unfactor :: Term -> CnvMonad Term unfactor :: Term -> CnvMonad Term
unfactor t = CM (\gr c -> c (unfac gr t)) 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 -- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated -- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index. -- 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]) type Env = (ProtoFCat, [ProtoFCat])
protoFCat :: GrammarEnv -> (Int,Cat) -> ProtoFCat protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat
protoFCat (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of case Map.lookup cat catSet of
Just (_,_,pfcat) -> pfcat Just (_,_,proto) -> PFCat (map snd ctxt) cat proto
Nothing -> error "unknown category" Nothing -> error "unknown category"
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
@@ -330,8 +366,9 @@ convertArg opts (Sort _) nr path = do
(args,_) <- get (args,_) <- get
let PFCat _ cat schema = args !! nr let PFCat _ cat schema = args !! nr
l = index (reversePath path) schema l = index (reversePath path) schema
sym | isLiteralCat opts cat = SymLit nr l sym | CProj (LVar i) CNil <- path = SymVar nr i
| otherwise = SymCat nr l | isLiteralCat opts cat = SymLit nr l
| otherwise = SymCat nr l
return (CStr [sym]) return (CStr [sym])
where where
index (CProj lbl path) (CRec rs) = case lookup lbl rs of 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 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 (env',(trm,b'))) env vs
in (env1,CTbl pt vs1) 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) in (env1,CStr seqid)
addSequencesV env (CPar i) = (env,CPar i) 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 -- GrammarEnv
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet
type CatSet = IntMap.IntMap (Map.Map Ident (FId,FId,ProtoFCat)) type Proto = Schema Identity Int (Int,[(Term,Int)])
type CatSet = Map.Map Ident (FId,FId,Proto)
type SeqSet = Map.Map Sequence SeqId type SeqSet = Map.Map Sequence SeqId
type FunSet = Map.Map CncFun FunId type FunSet = Map.Map CncFun FunId
type LinDefSet= IntMap.IntMap [FunId]
type CoerceSet= Map.Map [FId] FId 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) = emptyGrammarEnv gr (m,mo) =
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats 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 where
computeCatRange index cat ctype computeCatRange index cat ctype
| cat == cString = (index,(fidString,fidString,PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) | cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))]))
| cat == cInt = (index,(fidInt, fidInt, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) | cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))]))
| cat == cFloat = (index,(fidFloat, fidFloat, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))]))) | cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))]))
| otherwise = (index+size,(index,index+size-1,PFCat 0 cat schema)) | cat == cVar = (index,(fidFloat, fidFloat, CStr 0))
| otherwise = (index+size,(index,index+size-1,schema))
where where
((_,size),schema) = compute (0,1) ctype ((_,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',(lbl,Identity t'))) st rs
in (st',CRec rs') in (st',CRec rs')
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt) compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
@@ -478,96 +520,55 @@ emptyGrammarEnv gr (m,mo) =
Map.fromAscList Map.fromAscList
[(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)] [(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 -> FId -> Production -> GrammarEnv
addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p =
GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
addFSeq :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId) addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst = addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst =
case Map.lookup seq seqSet of case Map.lookup seq seqSet of
Just id -> (env,id) Just id -> (env,id)
Nothing -> let !last_seq = Map.size seqSet 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 where
seq = mkArray lst seq = mkArray lst
addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId) 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 case Map.lookup fun funSet of
Just id -> (env,id) Just id -> (env,id)
Nothing -> let !last_funid = Map.size funSet 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 :: 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 case sub_fcats of
[fcat] -> (env,fcat) [fcat] -> (env,fcat)
_ -> case Map.lookup sub_fcats crcSet of _ -> case Map.lookup sub_fcats crcSet of
Just fcat -> (env,fcat) Just fcat -> (env,fcat)
Nothing -> let !fcat = last_id+1 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 :: 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 Concr { cflags = flags
, printnames = printnames , printnames = printnames
, cncfuns = mkSetArray funSet , cncfuns = mkSetArray funSet
, lindefs = lindefSet
, sequences = mkSetArray seqSet , sequences = mkSetArray seqSet
, productions = IntMap.union prodSet coercions , productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty , pproductions = IntMap.empty
, lproductions = Map.empty , lproductions = Map.empty
, cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema)))) , 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 , totalCats = last_id+1
} }
where where
@@ -585,8 +586,8 @@ getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSe
getFIds :: GrammarEnv -> ProtoFCat -> [FId] getFIds :: GrammarEnv -> ProtoFCat -> [FId]
getFIds (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) = getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) =
case IntMap.lookup n catSet >>= Map.lookup cat of case Map.lookup cat catSet of
Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ()) Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
where where
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
@@ -611,9 +612,9 @@ restrictHead path term = do
put (head, args) put (head, args)
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat 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 schema <- addConstraint path v schema
return (PFCat n cat schema) return (PFCat ctxt cat schema)
where where
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs 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 addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs

13
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -71,19 +71,22 @@ children :: JS.Ident
children = JS.Ident "cs" children = JS.Ident "cs"
frule2js :: Production -> JS.Expr 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] 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))] 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 :: Array.Array DotPos Symbol -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
sym2js :: Symbol -> JS.Expr sym2js :: Symbol -> JS.Expr
sym2js (SymCat n l) = new "Arg" [JS.EInt n, JS.EInt l] sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "Lit" [JS.EInt n, JS.EInt l] sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l]
sym2js (SymKS ts) = new "KS" (map JS.EStr ts) sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l]
sym2js (SymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)] 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)] alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)]

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

@@ -247,7 +247,7 @@ defaultFlags = Flags {
optOutputFormats = [], optOutputFormats = [],
optSISR = Nothing, optSISR = Nothing,
optHaskellOptions = Set.empty, optHaskellOptions = Set.empty,
optLiteralCats = Set.fromList [cString,cInt,cFloat], optLiteralCats = Set.fromList [cString,cInt,cFloat,cVar],
optLexicalCats = Set.empty, optLexicalCats = Set.empty,
optGFODir = Nothing, optGFODir = Nothing,
optOutputFile = Nothing, optOutputFile = Nothing,

8
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -86,13 +86,11 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
mkRhs = concatMap symbolToCFSymbol . Array.elems mkRhs = concatMap symbolToCFSymbol . Array.elems
containsLiterals :: Array DotPos Symbol -> Bool containsLiterals :: Array DotPos Symbol -> Bool
containsLiterals row = any isPredefFId [args!!n | SymCat n _ <- Array.elems row] || containsLiterals row = not (null ([n | SymLit n _ <- Array.elems row] ++
not (null [n | SymLit n _ <- Array.elems row]) -- only this is needed for PMCFG. [n | SymVar n _ <- Array.elems row]))
-- The first line is for backward compat.
symbolToCFSymbol :: Symbol -> [CFSymbol] symbolToCFSymbol :: Symbol -> [CFSymbol]
symbolToCFSymbol (SymCat n l) = [NonTerminal (fcatToCat (args!!n) l)] symbolToCFSymbol (SymCat n l) = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)]
symbolToCFSymbol (SymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
symbolToCFSymbol (SymKS ts) = map Terminal ts symbolToCFSymbol (SymKS ts) = map Terminal ts
symbolToCFSymbol (SymKP ts as) = map Terminal $ ts symbolToCFSymbol (SymKP ts as) = map Terminal $ ts
---- ++ [t | Alt ss _ <- as, t <- ss] ---- ++ [t | Alt ss _ <- as, t <- ss]

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

@@ -51,6 +51,7 @@ instance Binary Concr where
put (printnames cnc) put (printnames cnc)
putArray2 (sequences cnc) putArray2 (sequences cnc)
putArray (cncfuns cnc) putArray (cncfuns cnc)
put (lindefs cnc)
put (productions cnc) put (productions cnc)
put (cnccats cnc) put (cnccats cnc)
put (totalCats cnc) put (totalCats cnc)
@@ -58,11 +59,13 @@ instance Binary Concr where
printnames <- get printnames <- get
sequences <- getArray2 sequences <- getArray2
cncfuns <- getArray cncfuns <- getArray
lindefs <- get
productions <- get productions <- get
cnccats <- get cnccats <- get
totalCats <- get totalCats <- get
return (Concr{ cflags=cflags, printnames=printnames return (Concr{ cflags=cflags, printnames=printnames
, sequences=sequences, cncfuns=cncfuns, productions=productions , sequences=sequences, cncfuns=cncfuns, lindefs=lindefs
, productions=productions
, pproductions = IntMap.empty , pproductions = IntMap.empty
, lproductions = Map.empty , lproductions = Map.empty
, cnccats=cnccats, totalCats=totalCats , cnccats=cnccats, totalCats=totalCats
@@ -141,16 +144,22 @@ instance Binary CncCat where
instance Binary Symbol where instance Binary Symbol where
put (SymCat n l) = putWord8 0 >> put (n,l) put (SymCat n l) = putWord8 0 >> put (n,l)
put (SymLit n l) = putWord8 1 >> put (n,l) put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymKS ts) = putWord8 2 >> put ts put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKP d vs) = putWord8 3 >> put (d,vs) put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM2 SymCat get get 0 -> liftM2 SymCat get get
1 -> liftM2 SymLit get get 1 -> liftM2 SymLit get get
2 -> liftM SymKS get 2 -> liftM2 SymVar get get
3 -> liftM2 (\d vs -> SymKP d vs) get get 3 -> liftM SymKS get
4 -> liftM2 (\d vs -> SymKP d vs) get get
_ -> decodingError _ -> 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 instance Binary Production where
put (PApply ruleid args) = putWord8 0 >> put (ruleid,args) put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
put (PCoerce fcat) = putWord8 1 >> put fcat put (PCoerce fcat) = putWord8 1 >> put fcat

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

@@ -36,6 +36,7 @@ data Concr = Concr {
cflags :: Map.Map CId Literal, -- value of a flag cflags :: Map.Map CId Literal, -- value of a flag
printnames :: Map.Map CId String, -- printname of a cat or a fun printnames :: Map.Map CId String, -- printname of a cat or a fun
cncfuns :: Array FunId CncFun, cncfuns :: Array FunId CncFun,
lindefs :: IntMap.IntMap [FunId],
sequences :: Array SeqId Sequence, sequences :: Array SeqId Sequence,
productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file
pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing
@@ -51,14 +52,16 @@ type DotPos = Int
data Symbol data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS [Token] | SymKS [Token]
| SymKP [Token] [Alternative] | SymKP [Token] [Alternative]
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data Production data Production
= PApply {-# UNPACK #-} !FunId [FId] = PApply {-# UNPACK #-} !FunId [PArg]
| PCoerce {-# UNPACK #-} !FId | PCoerce {-# UNPACK #-} !FId
| PConst CId Expr [Token] | PConst CId Expr [Token]
deriving (Eq,Ord,Show) 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 CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String)
data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show) data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show)
type Sequence = Array DotPos Symbol type Sequence = Array DotPos Symbol

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

@@ -14,12 +14,14 @@
module PGF.Forest( Forest(..) module PGF.Forest( Forest(..)
, BracketedString, showBracketedString, lengthBracketedString , BracketedString, showBracketedString, lengthBracketedString
, linearizeWithBrackets , linearizeWithBrackets
, getAbsTrees
, foldForest , foldForest
) where ) where
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Macros import PGF.Macros
import PGF.TypeCheck
import Data.List import Data.List
import Data.Array.IArray import Data.Array.IArray
import qualified Data.Set as Set import qualified Data.Set as Set
@@ -34,7 +36,7 @@ data Forest
{ abstr :: Abstr { abstr :: Abstr
, concr :: Concr , concr :: Concr
, forest :: IntMap.IntMap (Set.Set Production) , 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 :: Forest -> BracketedTokn
bracketedTokn f@(Forest abs cnc forest root) = 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 ([bs@(Bracket_ _ _ _ _ _)]:_) -> bs
(bss:_) -> Bracket_ wildCId 0 0 [] bss (bss:_) -> Bracket_ wildCId 0 0 [] bss
[] -> Bracket_ wildCId 0 0 [] [] [] -> Bracket_ wildCId 0 0 [] []
where where
isTrusted (_,fid) = IntSet.member fid trusted
trusted = foldl1 IntSet.intersection [IntSet.unions (map (trustedSpots IntSet.empty) args) | (_,args) <- root] 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 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) Nothing -> error ("wrong forest id " ++ show fid)
where where
descend forest (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid descend forest (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid
Just (DTyp _ cat _,_,_) = Map.lookup fun (funs abs) cat = case isLindefCId fun of
largs = map (render forest) args Just cat -> cat
ltable = listArray (bounds lins) Nothing -> case Map.lookup fun (funs abs) of
[computeSeq (elems (sequences cnc ! seqid)) largs | Just (DTyp _ cat _,_,_) -> cat
seqid <- elems lins] largs = map (render forest) args
in (fid,cat,ltable) ltable = mkLinTable cnc isTrusted [] funid largs
descend forest (PCoerce fid) = render forest fid in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable)
descend forest (PConst cat _ ts) = (fid,cat,listArray (0,0) [[LeafKS ts]]) 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 | fid < totalCats cnc || -- forest ids from the grammar correspond to metavariables
IntSet.member fid parents -- this avoids loops in the grammar IntSet.member fid parents -- this avoids loops in the grammar
= IntSet.empty = IntSet.empty
@@ -85,65 +97,116 @@ bracketedTokn f@(Forest abs cnc forest root) =
parents' = IntSet.insert fid parents parents' = IntSet.insert fid parents
descend (PApply funid args) = IntSet.unions (map (trustedSpots parents') args) 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 descend (PConst c e _) = IntSet.empty
computeSeq :: [Symbol] -> [(FId,CId,LinTable)] -> [BracketedTokn] isLindefCId id
computeSeq seq args = concatMap compute seq | take l s == lindef = Just (mkCId (drop l s))
where | otherwise = Nothing
compute (SymCat d r) = getArg d r where
compute (SymLit d r) = getArg d r s = showCId id
compute (SymKS ts) = [LeafKS ts] lindef = "lindef "
compute (SymKP ts alts) = [LeafKP ts alts] l = length lindef
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
-- | This function extracts the list of all completed parse trees -- | This function extracts the list of all completed parse trees
-- that spans the whole input consumed so far. The trees are also -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually -- limited by the category specified, which is usually
-- the same as the startup category. -- the same as the startup category.
getAbsTrees :: Forest -> FId -> [Expr] getAbsTrees :: Forest -> PArg -> Maybe Type -> Either [(FId,TcError)] [Expr]
getAbsTrees (Forest abs cnc forest root) fid = getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty =
nubsort $ do (fvs,e) <- go Set.empty 0 (0,fid) let (res,err) = unTcFM (do e <- go Set.empty emptyScope arg (fmap (TTyp []) ty)
guard (Set.null fvs) e <- runTcM abs fid (refineExpr e)
return 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 where
go rec_ fcat' (d,fcat) go rec_ scope_ (PArg hypos fid) mb_tty_
| fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments | fid < totalCats cnc = case mb_tty of
| Set.member fcat rec_ = mzero Just tty -> do i <- runTcM abs fid (newMeta scope tty)
| otherwise = foldForest (\funid args trees -> return (mkAbs (EMeta i))
Nothing -> mzero
| Set.member fid rec_ = mzero
| otherwise = foldForest (\funid args trees ->
do let CncFun fn lins = cncfuns cnc ! funid do let CncFun fn lins = cncfuns cnc ! funid
args <- mapM (go (Set.insert fcat rec_) fcat) (zip [0..] args) case isLindefCId fn of
check_ho_fun fn args 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` `mplus`
trees) trees)
(\const _ trees -> (\const _ trees -> do
return (freeVar const,const) const <- runTcM abs fid $
case mb_tty of
Just tty -> tcExpr scope const tty
Nothing -> fmap fst $ infExpr scope const
return (mkAbs const)
`mplus` `mplus`
trees) trees)
[] fcat forest mzero fid forest
where
(scope,mkAbs,mb_tty) = updateScope hypos scope_ id mb_tty_
check_ho_fun fun args goArg rec_ scope fid e1 arg (TTyp delta (DTyp ((bt,x,ty):hs) c es)) = do
| fun == _V = return (head args) e2' <- go rec_ scope arg (Just (TTyp delta ty))
| fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args)) let e2 = case bt of
| otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args) Explicit -> e2'
Implicit -> EImplArg e2'
mkVar (EFun v) = v if x == wildCId
mkVar (EMeta _) = wildCId then return (EApp e1 e2,TTyp delta (DTyp hs c es))
else do v2 <- runTcM abs fid (eval (scopeEnv scope) e2')
freeVar (EFun v) = Set.singleton v return (EApp e1 e2,TTyp (v2:delta) (DTyp hs c es))
freeVar _ = Set.empty
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 = foldForest f g b fcat forest =
case IntMap.lookup fcat forest of case IntMap.lookup fcat forest of
Nothing -> b Nothing -> b

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

@@ -23,7 +23,7 @@ import qualified Data.Set as Set
-- | Linearizes given expression as string in the language -- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String 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 same as 'linearizeAllLang' but does not return
-- the language. -- 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 -- | Linearizes given expression as a bracketed string in the language
bracketedLinearize :: PGF -> Language -> Tree -> BracketedString 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 where
head [] = error "cannot linearize" head [] = error "cannot linearize"
head (bs:bss) = bs head (bs:bss) = bs
firstLin (_,arr)
| inRange (bounds arr) 0 = arr ! 0
| otherwise = LeafKS []
-- | Creates a table from feature name to linearization. -- | Creates a table from feature name to linearization.
-- The outher list encodes the variations -- The outher list encodes the variations
tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]] tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]]
tabularLinearizes pgf lang e = map (zip lbls . map (unwords . concatMap flattenBracketedString . snd . untokn "") . elems) tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
(linTree pgf lang e)
where where
lbls = case unApp e of cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn "") (elems lin)
Just (f,_) -> let cat = valCat (lookType pgf f)
in case Map.lookup cat (cnccats (lookConcr pgf lang)) of lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
Just (CncCat _ _ lbls) -> elems lbls Just (CncCat _ _ lbls) -> elems lbls
Nothing -> error "No labels" Nothing -> error "No labels"
Nothing -> error "Not function application"
-------------------------------------------------------------------- --------------------------------------------------------------------
-- Implementation -- Implementation
-------------------------------------------------------------------- --------------------------------------------------------------------
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)]
linTree :: PGF -> Language -> Expr -> [Array LIndex BracketedTokn]
linTree pgf lang e = 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 where
cnc = lookMap (error "no lang") lang (concretes pgf) cnc = lookMap (error "no lang") lang (concretes pgf)
lp = lproductions cnc 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 mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
lin xs mb_cty n_fid e0 (ELit l) [] = case l of lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es)
LStr s -> return (n_fid+1,((cidString,n_fid),e0,ss s)) lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es
LInt n -> return (n_fid+1,((cidInt, n_fid),e0,ss (show n))) lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es
LFlt f -> return (n_fid+1,((cidFloat, n_fid),e0,ss (show f))) lin mb_cty n_fid e0 ys xs (EFun f) es = apply mb_cty n_fid e0 ys xs f es
lin xs mb_cty n_fid e0 (EMeta i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr ('?':show i)):es) lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i)
lin xs mb_cty n_fid e0 (EFun f) es = apply xs mb_cty n_fid e0 f es lin mb_cty n_fid e0 ys xs (EVar i) [] = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i))
lin xs mb_cty n_fid e0 (EVar i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr (xs !! i)) :es) lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of
lin xs mb_cty n_fid e0 (ETyped e _) es = lin xs mb_cty n_fid e0 e es LStr s -> return (n_fid+1,((cidString,n_fid),[e0],([],ss s)))
lin xs mb_cty n_fid e0 (EImplArg e) es = lin xs mb_cty n_fid e0 e es 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]]] ss s = listArray (0,0) [[LeafKS [s]]]
apply :: [String] -> Maybe CncType -> FId -> Expr -> CId -> [Expr] -> [(FId,(CncType, Expr, LinTable))] apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, [Expr], LinTable))]
apply xs mb_cty n_fid e0 f es = apply mb_cty n_fid e0 ys xs f es =
case Map.lookup f lp of case Map.lookup f lp of
Just prods -> do (funid,(cat,fid),ctys) <- getApps prods Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
guard (length ctys == length es)
(n_fid,args) <- descend n_fid (zip ctys es) (n_fid,args) <- descend n_fid (zip ctys es)
let (CncFun _ lins) = cncfuns cnc ! funid return (n_fid+1,((cat,n_fid),[e0],mkLinTable cnc (const True) xs funid args))
return (n_fid+1,((cat,n_fid),e0,listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])) Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin
Nothing -> apply xs mb_cty n_fid e0 _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
where where
getApps prods = getApps prods =
case mb_cty of case mb_cty of
Just cty@(cat,fid) -> maybe [] (concatMap (toApp cty) . Set.toList) (IntMap.lookup fid prods) Just (cat,fid) -> maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods)
Nothing | f == _B Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
|| f == _V -> []
| otherwise -> concat [toApp (wildCId,fid) prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where where
toApp cty (PApply funid fids) toApp fid (PApply funid pargs) =
| f == _V = [(funid,cty,zip ( repeat cidVar) fids)] let Just (ty,_,_) = Map.lookup f (funs (abstract pgf))
| f == _B = [(funid,cty,zip (fst cty : repeat cidVar) fids)] (args,res) = catSkeleton ty
| otherwise = let Just (ty,_,_) = Map.lookup f (funs (abstract pgf)) in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
(args,res) = catSkeleton ty toApp _ (PCoerce fid) =
in [(funid,(res,snd cty),zip args fids)] maybe [] (concatMap (toApp fid) . Set.toList) (IntMap.lookup fid prods)
toApp cty (PCoerce fid) = concatMap (toApp cty) (maybe [] Set.toList (IntMap.lookup fid prods))
descend n_fid [] = return (n_fid,[]) 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 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 (n_fid,args) <- descend n_fid fes
return (n_fid,arg:args) return (n_fid,arg:args)
computeSeq :: SeqId -> [(CncType,Expr,LinTable)] -> [BracketedTokn] def (Just (cat,fid)) n_fid e0 ys xs s =
computeSeq seqid args = concatMap compute (elems seq) case IntMap.lookup fid (lindefs cnc) of
where Just funs -> do funid <- funs
seq = sequences cnc ! seqid let args = [((wildCId, n_fid),[e0],([],ss s))]
return (n_fid+2,((cat,n_fid+1),[e0],mkLinTable cnc (const True) xs funid args))
compute (SymCat d r) = getArg d r Nothing
compute (SymLit d r) = getArg d r | isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),[e0],(xs,listArray (0,0) [[LeafKS [s]]])))
compute (SymKS ts) = [LeafKS ts] | otherwise -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
compute (SymKP ts alts) = [LeafKP ts alts] def (Just (cat,fid)) n_fid e0 ys xs s
def Nothing n_fid e0 ys xs s = []
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
amapWithIndex :: (IArray a e1, IArray a e2, Ix i) => (i -> e1 -> e2) -> a i e1 -> a i e2 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)) amapWithIndex f arr = listArray (bounds arr) (map (uncurry f) (assocs arr))

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

@@ -10,6 +10,7 @@ import qualified Data.IntSet as IntSet
import qualified Data.Array as Array import qualified Data.Array as Array
import Data.Maybe import Data.Maybe
import Data.List import Data.List
import Data.Array.IArray
import Text.PrettyPrint import Text.PrettyPrint
-- operations for manipulating PGF grammars and objects -- operations for manipulating PGF grammars and objects
@@ -132,9 +133,6 @@ cidInt = mkCId "Int"
cidFloat = mkCId "Float" cidFloat = mkCId "Float"
cidVar = mkCId "__gfVar" cidVar = mkCId "__gfVar"
_B = mkCId "__gfB"
_V = mkCId "__gfV"
-- Utilities for doing linearization -- Utilities for doing linearization
@@ -162,7 +160,7 @@ data BracketedTokn
| Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex [Expr] [BracketedTokn] -- Invariant: the list is not empty | Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex [Expr] [BracketedTokn] -- Invariant: the list is not empty
deriving Eq deriving Eq
type LinTable = Array.Array LIndex [BracketedTokn] type LinTable = ([CId],Array.Array LIndex [BracketedTokn])
-- | Renders the bracketed string as string where -- | Renders the bracketed string as string where
-- the brackets are shown as @(S ...)@ 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 let (nw',bss') = mapAccumR untokn nw bss
in (nw',[Bracket cat fid index es (concat 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 :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w] flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss

91
src/runtime/haskell/PGF/Optimize.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
module PGF.Optimize module PGF.Optimize
( optimizePGF ( optimizePGF
, updateProductionIndices , updateProductionIndices
@@ -16,6 +17,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.IntSet as IntSet import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Control.Monad.ST import Control.Monad.ST
import GF.Data.Utilities(sortNub) import GF.Data.Utilities(sortNub)
@@ -29,14 +31,20 @@ updateProductionIndices pgf = pgf{concretes = fmap (updateConcrete (abstract pgf
topDownFilter :: CId -> Concr -> Concr topDownFilter :: CId -> Concr -> Concr
topDownFilter startCat cnc = topDownFilter startCat cnc =
let ((seqs,funs),prods) = IntMap.mapAccumWithKey (\env res set -> mapAccumLSet (optimize res) env set) let env0 = (Map.empty,Map.empty)
(Map.empty,Map.empty) (env1,defs) = IntMap.mapAccumWithKey (\env fid funids -> mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids)
(productions cnc) env0
(lindefs cnc)
(env2,prods) = IntMap.mapAccumWithKey (\env fid set -> mapAccumLSet (optimizeProd fid) env set)
env1
(productions cnc)
cats = Map.mapWithKey filterCatLabels (cnccats cnc) cats = Map.mapWithKey filterCatLabels (cnccats cnc)
(seqs,funs) = env2
in cnc{ sequences = mkSetArray seqs in cnc{ sequences = mkSetArray seqs
, cncfuns = mkSetArray funs , cncfuns = mkSetArray funs
, productions = prods , productions = prods
, cnccats = cats , cnccats = cats
, lindefs = defs
} }
where where
fid2cat fid = fid2cat fid =
@@ -46,8 +54,8 @@ topDownFilter startCat cnc =
(fid:_) -> fid2cat fid (fid:_) -> fid2cat fid
_ -> error "unknown forest id" _ -> error "unknown forest id"
where where
fid2catMap = IntMap.fromList [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc), fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc),
fid <- [start..end]] fid <- [start..end]])
starts = starts =
case Map.lookup startCat (cnccats cnc) of case Map.lookup startCat (cnccats cnc) of
@@ -64,11 +72,11 @@ topDownFilter startCat cnc =
CncFun _ lin = cncfuns cnc ! funid CncFun _ lin = cncfuns cnc ! funid
rel fid _ = Map.empty 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 where
seq = sequences cnc ! seqid 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 -- 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 -- is not going to be used in the optimized grammar, or the new index
-- if it will be used -- if it will be used
@@ -122,11 +130,16 @@ topDownFilter startCat cnc =
reindex indices (i+1) j (k+1) reindex indices (i+1) j (k+1)
| otherwise = return () | 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) | let (seqs',lin') = mapAccumL addUnique seqs [amap updateSymbol (sequences cnc ! seqid) |
(lbl,seqid) <- assocs lin, indicesOf res ! lbl >= 0] (lbl,seqid) <- assocs lin, indicesOf res ! lbl >= 0]
(funs',funid') = addUnique funs (CncFun fun (mkArray lin')) (funs',funid') = addUnique funs (CncFun fun (mkArray lin'))
in ((seqs',funs'), PApply funid' args) in ((seqs',funs'), funid')
where where
CncFun fun lin = cncfuns cnc ! funid CncFun fun lin = cncfuns cnc ! funid
@@ -140,11 +153,10 @@ topDownFilter startCat cnc =
Just seqid -> (seqs,seqid) Just seqid -> (seqs,seqid)
Nothing -> let seqid = Map.size seqs Nothing -> let seqid = Map.size seqs
in (Map.insert seq seqid seqs, seqid) 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 updateSymbol s = s
optimize res env prod = (env,prod)
filterCatLabels cat (CncCat start end lbls) = filterCatLabels cat (CncCat start end lbls) =
case Map.lookup cat closure of case Map.lookup cat closure of
Just indices -> let lbls' = mkArray [lbl | (i,lbl) <- assocs lbls, indices ! i >= 0] Just indices -> let lbls' = mkArray [lbl | (i,lbl) <- assocs lbls, indices ! i >= 0]
@@ -159,50 +171,35 @@ topDownFilter startCat cnc =
bottomUpFilter :: Concr -> Concr 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 | prods0 == prods1 = prods0
| otherwise = filterProductions prods1 prods | otherwise = filterProductions prods1 hoc1 prods
where 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 foldProdSet fid set (!prods,!hoc)
| Set.null set1 = Nothing | Set.null set1 = (prods,hoc)
| otherwise = Just set1 | otherwise = (IntMap.insert fid set1 prods,hoc1)
where 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 (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
filterRule prods0 (PCoerce fid) = isPredefFId fid || IntMap.member fid prods0 filterRule (PCoerce fid) = isLive fid
filterRule prods0 _ = True 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 = updateConcrete abs cnc =
let p_prods = (filterProductions IntMap.empty . parseIndex cnc) (productions cnc) let p_prods = filterProductions IntMap.empty IntSet.empty (productions cnc)
l_prods = (linIndex cnc . filterProductions IntMap.empty) (productions cnc) l_prods = linIndex cnc p_prods
in cnc{pproductions = p_prods, lproductions = l_prods} in cnc{pproductions = p_prods, lproductions = l_prods}
where 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 = linIndex cnc productions =
Map.fromListWith (IntMap.unionWith Set.union) Map.fromListWith (IntMap.unionWith Set.union)
[(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions [(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions

174
src/runtime/haskell/PGF/Parse.hs
View File

@@ -28,7 +28,7 @@ import PGF.Data
import PGF.Expr(Tree) import PGF.Expr(Tree)
import PGF.Macros import PGF.Macros
import PGF.TypeCheck 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 -- | The input to the parser is a pair of predicates. The first one
-- 'piToken' checks that a given token, suggested by the grammar, -- '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. -- 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. | 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. -- 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 -> Language -> Type -> [Token] -> (ParseOutput,BracketedString)
parse pgf lang typ toks = loop (initState pgf lang typ) toks parse pgf lang typ toks = loop (initState pgf lang typ) toks
@@ -108,7 +109,7 @@ simpleParseInput t = ParseInput (==t) (matchLit t)
_ -> Nothing } _ -> Nothing }
| fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]); | fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]);
_ -> Nothing } _ -> Nothing }
| fid == fidVar = Just (cidVar,EFun (mkCId t),[t]) | fid == fidVar = Just (wildCId,EFun (mkCId t),[t])
| otherwise = Nothing | otherwise = Nothing
mkParseInput :: PGF -> Language -> (a -> Token -> Bool) -> [(CId,a -> Maybe (Tree,[Token]))] -> a -> ParseInput 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 let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = TMap.unions [tmap | (t,tmap) <- Map.toList map_items, piToken input t] 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 chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -166,7 +167,7 @@ getCompletions (PState pgf cnc chart items) w =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items 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 chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -184,7 +185,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState)
recoveryStates open_types (EState pgf cnc chart) = recoveryStates open_types (EState pgf cnc chart) =
let open_fcats = concatMap type2fcats open_types let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart) 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 chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -200,7 +201,7 @@ recoveryStates open_types (EState pgf cnc chart) =
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
(:) (Active j' (ppos+1) funid seqid args keyc))) (:) (Active j' (ppos+1) funid seqid args keyc)))
items items
[set | fcat <- open_fcats, set <- lookupACByFCat fcat ac] [set | fcat <- open_fcats, (set,_) <- lookupACByFCat fcat ac]
flit _ = Nothing flit _ = Nothing
ftok (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc 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 :: ParseState -> Type -> (ParseOutput,BracketedString)
getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) = getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) =
let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq 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) f = Forest (abstract pgf) cnc (forest chart1) froots
exps = nubsort $ do bs = linearizeWithBrackets f
(AK fid lbl) <- roots
(fvs,e) <- go Set.empty 0 (0,fid) res | not (null es) = ParseOk es
guard (Set.null fvs) | not (null errs) = TypeError errs
Right e1 <- [checkExpr pgf e ty] | otherwise = ParseIncomplete
return e1 where xs = [getAbsTrees f (PArg [] fid) (Just ty) | (AK fid lbl) <- roots]
es = concat [es | Right es <- xs]
res = if null exps errs = concat [errs | Left errs <- xs]
then ParseFailed (offset chart)
else ParseOk exps
in (res,bs) in (res,bs)
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda 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] 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 flit _ = Nothing
@@ -255,32 +254,6 @@ getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) =
return (AK fid lbl) return (AK fid lbl)
Nothing -> mzero 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 getPartialSeq seqs actives = expand Set.empty
where where
expand acc [] = expand acc [] =
@@ -291,72 +264,99 @@ getPartialSeq seqs actives = expand Set.empty
where where
acc' = Set.insert item acc acc' = Set.insert item acc
items' = case lookupAC key (actives !! j) of items' = case lookupAC key (actives !! j) of
Nothing -> items Nothing -> items
Just set -> [if j' < j Just (set,_) -> [if j' < j
then let lin' = take ppos (elems (unsafeAt seqs seqid)) then let lin' = take ppos (elems (unsafeAt seqs seqid))
in (j',lin'++map (inc (length args')) lin,args'++args,key') 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 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 (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 (SymLit d r) = SymLit (n+d) r
inc n s = s inc n s = s
process flit ftok !seqs !funs [] acc chart = (acc,chart) process flit ftok !seqs !funs defs [] 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 (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos = | inRange (bounds lin) ppos =
case unsafeAt lin ppos of 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 key = AK fid r
items2 = case lookupPC (mkPK key k) (passive chart) of items2 = case lookupPC (mkPK key k) (passive chart) of
Nothing -> items 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) items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)
(\_ _ items -> 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 in case lookupAC key (active chart) of
Nothing -> process flit ftok seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} Nothing -> process flit ftok seqs funs defs items3 acc chart{active=insertAC key (Set.singleton item,new_sc) (active chart)}
Just set | Set.member item set -> process flit ftok seqs funs items acc chart Just (set,sc) | Set.member item set -> process flit ftok seqs funs defs items acc chart
| otherwise -> process flit ftok seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active 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 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 SymKP strs vars
-> let !acc' = foldl (\acc toks -> ftok toks (Active j (ppos+1) funid seqid args key0) acc) acc -> let !acc' = foldl (\acc toks -> ftok toks (Active j (ppos+1) funid seqid args key0) acc) acc
(strs:[strs' | Alt strs' _ <- vars]) (strs:[strs' | Alt strs' _ <- vars])
in process flit ftok seqs funs items acc' chart in process flit ftok seqs funs defs items acc' chart
SymLit d r -> let fid = args !! d SymLit d r -> let PArg hypos fid = args !! d
key = AK fid r key = AK fid r
!fid' = case lookupPC (mkPK key k) (passive chart) of !fid' = case lookupPC (mkPK key k) (passive chart) of
Nothing -> fid Nothing -> fid
Just fid -> fid Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of 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 (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 items acc' chart in process flit ftok seqs funs defs items acc' chart
[] -> case flit fid of [] -> case flit fid of
Just (cat,lit,toks) Just (cat,lit,toks)
-> let fid' = nextId chart -> let fid' = nextId chart
!acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc
in process flit ftok seqs funs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart) 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) ,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1 ,nextId =nextId chart+1
} }
Nothing -> process flit ftok seqs funs items acc chart{active=insertAC key (Set.singleton item) (active chart)} 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 = | otherwise =
case lookupPC (mkPK key0 j) (passive chart) of case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart Nothing -> let fid = nextId chart
items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of
Nothing -> items Nothing -> items
Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> Just (set,sc) -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set PArg hypos _ = args !! d
in process flit ftok seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) in (:) (Active j' (ppos+1) funid seqid (updateAt d (PArg hypos fid) args) keyc)) items set
,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart) in process flit ftok seqs funs defs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,nextId =nextId chart+1 ,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 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 where
!lin = unsafeAt seqs seqid !lin = unsafeAt seqs seqid
!k = offset chart !k = offset chart
@@ -367,6 +367,10 @@ process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items)
where where
CncFun _ lins = unsafeAt funs funid 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 :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] 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 #-} !DotPos
{-# UNPACK #-} !FunId {-# UNPACK #-} !FunId
{-# UNPACK #-} !SeqId {-# UNPACK #-} !SeqId
[FId] [PArg]
{-# UNPACK #-} !ActiveKey {-# UNPACK #-} !ActiveKey
deriving (Eq,Show,Ord) deriving (Eq,Show,Ord)
data ActiveKey data ActiveKey
= AK {-# UNPACK #-} !FId = AK {-# UNPACK #-} !FId
{-# UNPACK #-} !LIndex {-# UNPACK #-} !LIndex
deriving (Eq,Ord,Show) 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 :: ActiveChart
emptyAC = IntMap.empty 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 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 = lookupACByFCat fcat chart =
case IntMap.lookup fcat chart of case IntMap.lookup fcat chart of
Nothing -> [] Nothing -> []
@@ -408,7 +412,7 @@ labelsAC fcat chart =
Nothing -> [] Nothing -> []
Just map -> IntMap.keys map 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 insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart

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

@@ -46,7 +46,9 @@ ppCnc name cnc =
nest 2 (ppAll ppFlag (cflags cnc) $$ nest 2 (ppAll ppFlag (cflags cnc) $$
text "productions" $$ text "productions" $$
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$ 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)))) $$ nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
text "sequences" $$ text "sequences" $$
nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$ nest 2 (vcat (map ppSeq (assocs (sequences cnc)))) $$
@@ -56,8 +58,13 @@ ppCnc name cnc =
nest 2 (vcat (map ppPrintName (Map.toList (printnames cnc))))) $$ nest 2 (vcat (map ppPrintName (Map.toList (printnames cnc))))) $$
char '}' 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) = 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) = ppProduction (fid,PCoerce arg) =
ppFId fid <+> text "->" <+> char '_' <> brackets (ppFId arg) ppFId fid <+> text "->" <+> char '_' <> brackets (ppFId arg)
ppProduction (fid,PConst _ _ ss) = ppProduction (fid,PConst _ _ ss) =
@@ -66,6 +73,9 @@ ppProduction (fid,PConst _ _ ss) =
ppCncFun (funid,CncFun fun arr) = ppCncFun (funid,CncFun fun arr) =
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) 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) = ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems 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 (SymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (SymLit 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 (SymKS ts) = ppStrs ts
ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts))) ppSymbol (SymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts)))

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

@@ -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 ) where
import PGF.Data import PGF.Data
@@ -65,7 +73,7 @@ scopeSize (Scope gamma) = length gamma
type MetaStore = IntMap MetaValue type MetaStore = IntMap MetaValue
data MetaValue data MetaValue
= MUnbound Scope [Expr -> TcM ()] = MUnbound Scope TType [Expr -> TcM ()]
| MBound Expr | MBound Expr
| MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved | MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved
-- to unlock this meta variable -- 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) Just (ty,_,_) -> Ok ms (TTyp [] ty)
Nothing -> Fail (UnknownFun fun)) Nothing -> Fail (UnknownFun fun))
newMeta :: Scope -> TcM MetaId newMeta :: Scope -> TType -> TcM MetaId
newMeta scope = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1
in Ok (IntMap.insert metaid (MUnbound scope []) ms) metaid) in Ok (IntMap.insert metaid (MUnbound scope tty []) ms) metaid)
newGuardedMeta :: Expr -> TcM MetaId newGuardedMeta :: Expr -> TcM MetaId
newGuardedMeta e = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 newGuardedMeta e = TcM (\abstr ms -> let metaid = IntMap.size ms + 1
@@ -115,7 +123,7 @@ lookupMeta ms i =
Just (MBound t) -> Just t Just (MBound t) -> Just t
Just (MGuarded t _ x) | x == 0 -> Just t Just (MGuarded t _ x) | x == 0 -> Just t
| otherwise -> Nothing | otherwise -> Nothing
Just (MUnbound _ _) -> Nothing Just (MUnbound _ _ _) -> Nothing
Nothing -> Nothing Nothing -> Nothing
tcError :: TcError -> TcM a tcError :: TcError -> TcM a
@@ -125,7 +133,7 @@ addConstraint :: MetaId -> MetaId -> Env -> [Value] -> (Value -> TcM ()) -> TcM
addConstraint i j env vs c = do addConstraint i j env vs c = do
mv <- getMeta j mv <- getMeta j
case mv of 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 MBound e -> apply env e vs >>= c
MGuarded e cs x | x == 0 -> 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) | 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. | 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. | 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 | 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'. -- | Renders the type checking error to a document. See 'Text.PrettyPrint'.
ppTcError :: TcError -> Doc 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" $$ 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 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 (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 -- 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 tcCatArgs scope es (v:delta) hs ty0 n m
return (delta,EImplArg e:es) return (delta,EImplArg e:es)
tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do 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 (delta,es) <- if x == wildCId
then tcCatArgs scope es delta hs ty0 n m then tcCatArgs scope es delta hs ty0 n m
else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : 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 _ -> do ty <- evalType (scopeSize scope) tty
tcError (NotFunType (scopeVars scope) e0 ty) tcError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope (EMeta _) tty = do tcExpr scope (EMeta _) tty = do
i <- newMeta scope i <- newMeta scope tty
return (EMeta i) return (EMeta i)
tcExpr scope e0 tty = do tcExpr scope e0 tty = do
(e0,tty0) <- infExpr scope e0 (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 else do v2 <- eval (scopeEnv scope) e2
return (EApp e1 e2,v2:delta,DTyp hs c es) return (EApp e1 e2,v2:delta,DTyp hs c es)
tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do 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 if x == wildCId
then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es) 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) 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 MBound e -> apply env e vs
MGuarded e _ x | x == 0 -> apply env e vs MGuarded e _ x | x == 0 -> apply env e vs
| otherwise -> return v | otherwise -> return v
MUnbound _ _ -> return v MUnbound _ _ _ -> return v
deRef v = 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) 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) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2
eqValue' k (VMeta i env1 vs1) v2 = do mv <- getMeta i eqValue' k (VMeta i env1 vs1) v2 = do mv <- getMeta i
case mv of case mv of
MUnbound scopei cs -> do e2 <- mkLam i scopei env1 vs1 v2 MUnbound scopei _ cs -> do e2 <- mkLam i scopei env1 vs1 v2
setMeta i (MBound e2) setMeta i (MBound e2)
sequence_ [c e2 | c <- cs] 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) 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 eqValue' k v1 (VMeta i env2 vs2) = do mv <- getMeta i
case mv of case mv of
MUnbound scopei cs -> do e1 <- mkLam i scopei env2 vs2 v1 MUnbound scopei _ cs -> do e1 <- mkLam i scopei env2 vs2 v1
setMeta i (MBound e1) setMeta i (MBound e1)
sequence_ [c e1 | c <- cs] 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) 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 (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 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 () else return ()
mv <- getMeta i mv <- getMeta i
case mv of case mv of
MBound e -> apply env e vs >>= occurCheck i0 k xs MBound e -> apply env e vs >>= occurCheck i0 k xs
MGuarded 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 MUnbound scopei _ _ | scopeSize scopei > k -> raiseTypeMatchError
| otherwise -> do vs <- mapM (occurCheck i0 k xs) vs | otherwise -> do vs <- mapM (occurCheck i0 k xs) vs
return (VMeta i env 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 ()) 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) return (VSusp i env vs cnt)
occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of 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 () then Ok ms ()
else Fail (UnresolvedMetaVars (scopeVars scope) e xs)) else Fail (UnresolvedMetaVars (scopeVars scope) e xs))
where where
isResolved (MUnbound _ []) = True isResolved (MUnbound _ _ []) = True
isResolved (MGuarded _ _ _) = True isResolved (MGuarded _ _ _) = True
isResolved (MBound _) = True isResolved (MBound _) = True
isResolved _ = False isResolved _ = False

18
src/runtime/haskell/PGF/VisualizeTree.hs
View File

@@ -28,7 +28,7 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId)
import PGF.Data import PGF.Data
import PGF.Expr (showExpr, Tree) import PGF.Expr (showExpr, Tree)
import PGF.Linearize import PGF.Linearize
import PGF.Macros (lookValCat, lookMap, _B, _V, import PGF.Macros (lookValCat, lookMap,
BracketedString(..), BracketedTokn(..), flattenBracketedString) BracketedString(..), BracketedTokn(..), flattenBracketedString)
import qualified Data.Map as Map 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 (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 (ETyped e _) = lin0 path xs ys mb_fid e
lin0 path xs ys mb_fid e | null xs = lin path ys mb_fid e [] lin0 path xs ys mb_fid e = lin path ys mb_fid e []
| otherwise = apply path (xs ++ ys) mb_fid _B (e:[ELit (LStr x) | x <- xs])
lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es) 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 lin path xs mb_fid (ELit l) [] = case l of
LStr s -> return (mark Nothing path (ss s)) LStr s -> return (mark Nothing path (ss s))
LInt n -> return (mark Nothing path (ss (show n))) LInt n -> return (mark Nothing path (ss (show n)))
LFlt f -> return (mark Nothing path (ss (show f))) 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 (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 (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 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 Just set -> do prod <- Set.toList set
case prod of case prod of
PApply funid fids -> do guard (length fids == length es) 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 let (CncFun _ lins) = cncfuns cnc ! funid
return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]) return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
PCoerce fid -> apply path xs (Just fid) f es PCoerce fid -> apply path xs (Just fid) f es
Nothing -> mzero Nothing -> mzero
Nothing -> apply path xs mb_fid _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
where where
lookupProds (Just fid) prods = IntMap.lookup fid prods lookupProds (Just fid) prods = IntMap.lookup fid prods
lookupProds Nothing prods lookupProds Nothing prods = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
| f == _B || f == _V = Nothing
| otherwise = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
sub i path sub i path = i:path
| f == _B || f == _V = path
| otherwise = i:path
isApp (PApply _ _) = True isApp (PApply _ _) = True
isApp _ = False isApp _ = False

1
src/server/PGFService.hs
View File

@@ -135,6 +135,7 @@ doTranslate pgf input mcat mfrom mto =
| (to,output) <- linearizeAndBind pgf mto tree] | (to,output) <- linearizeAndBind pgf mto tree]
)] )]
| tree <- trees])] | tree <- trees])]
jsonParseOutput (PGF.ParseIncomplete)= []
jsonParseOutput (PGF.ParseFailed _) = [] jsonParseOutput (PGF.ParseFailed _) = []
jsonParseOutput (PGF.TypeError errs) = [("typeErrors",showJSON [toJSObject [("fid", showJSON fid) jsonParseOutput (PGF.TypeError errs) = [("typeErrors",showJSON [toJSObject [("fid", showJSON fid)
,("msg", showJSON (show (PGF.ppTcError err))) ,("msg", showJSON (show (PGF.ppTcError err)))