msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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 f77af89683
commit 9aa7c88c5a
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):" $$
nest 2 (vcat (map (ppTcError . snd) errs)))
++ "\n" ++ msg)
ParseFailed i -> ([], "parse failed at token " ++ show (words s !! max 0 (i-1))
ParseFailed i -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1))
++ "\n" ++ msg)
ParseIncomplete-> ([], "The sentence is not complete")
where
(es,msg) = fromParse opts ps

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

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

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

@@ -44,21 +44,26 @@ import Control.Exception
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
convertConcrete opts0 gr am cm = do
let env0 = emptyGrammarEnv gr cm
let env = emptyGrammarEnv gr cm
when (flag optProf opts) $ do
profileGrammar cm env0 pfrules
env1 <- expandHOAS opts cm env0
env2 <- foldM (convertRule gr opts) env1 pfrules
return $ getConcr flags printnames env2
profileGrammar cm env pfrules
env <- foldM (convertLinDef gr opts) env pflindefs
env <- foldM (convertRule gr opts) env pfrules
return $ getConcr flags printnames env
where
(m,mo) = cm
opts = addOptions (M.flags (snd am)) opts0
pflindefs = [
((m,id),term,lincat) |
(id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (M.jments mo)]
pfrules = [
(PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) |
(PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) |
(id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo),
let (args,res) = err error typeSkeleton (lookupFunType gr (fst am) id)]
let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id)
args = [catSkeleton ty | (_,_,ty) <- ctxt]]
flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (M.flags mo)]
@@ -75,15 +80,13 @@ convertConcrete opts0 gr am cm = do
i2i :: Ident -> CId
i2i = CId . ident2bs
profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do
hPutStrLn stderr ""
hPutStrLn stderr ("Language: " ++ showIdent m)
hPutStrLn stderr ""
hPutStrLn stderr "Categories Count"
hPutStrLn stderr "--------------------------------"
case IntMap.lookup 0 catSet of
Just cats -> mapM_ profileCat (Map.toList cats)
Nothing -> return ()
mapM_ profileCat (Map.toList catSet)
hPutStrLn stderr "--------------------------------"
hPutStrLn stderr ""
hPutStrLn stderr "Rules Count"
@@ -98,8 +101,8 @@ profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSe
let pargs = map (protoFCat env) args
hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
where
catFactor (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of
catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) =
case Map.lookup cat catSet of
Just (s,e,_) -> e-s+1
Nothing -> 0
@@ -109,12 +112,40 @@ profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSe
rformat :: Int -> String -> String
rformat n s = replicate (n-length s) ' ' ++ s
data ProtoFRule = PFRule Ident {- function -}
[(Int,Cat)] {- argument types: context size and category -}
(Int,Cat) {- result type : context size (always 0) and category -}
[Type] {- argument lin-types representation -}
Type {- result lin-type representation -}
Term {- body -}
data ProtoFRule = PFRule Ident {- function -}
[([Cat],Cat)] {- argument types: context size and category -}
([Cat],Cat) {- result type : context size (always 0) and category -}
[Type] {- argument lin-types representation -}
Type {- result lin-type representation -}
Term {- body -}
optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv
optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet
where
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps])
where
ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
ff funid xs env
| product (map Set.size ys) == count
= case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of
(env,args) -> let xs = sequence (zipWith addContext pargs args)
in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs
| otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args)
in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs
where
count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt
return (PArg hyps fid)
toCncHypo cat =
case Map.lookup cat catSet of
Just (s,e,_) -> do fid <- range (s,e)
guard (fid `IntMap.member` lindefSet)
return (fidVar,fid)
Nothing -> mzero
convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
@@ -123,12 +154,13 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
(grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv
(goB b1 CNil [])
(pres,pargs) ) grammarEnv1
grammarEnv2 = foldBM addRule
grammarEnv1
(goB b1 CNil [])
(pres,pargs)
grammarEnv3 = optimize pargs grammarEnv2
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
return $! grammarEnv2
return $! grammarEnv3
where
addRule lins (newCat', newArgs') env0 =
let [newCat] = getFIds env0 newCat'
@@ -136,24 +168,28 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
(env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins))
in addProduction env2 newCat (PApply funid newArgs)
in addApplication env2 newCat (funid,newArgs)
brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv)
brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of
(GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1
convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv
convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do
let pres = protoFCat grammarEnv ([],cat)
parg = protoFCat grammarEnv ([],(identW,cVar))
b = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[])
(grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = foldBM addRule
grammarEnv1
(goB b1 CNil [])
(pres,[parg])
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId)
return $! grammarEnv2
where
optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | PApply funid args <- Set.toList ps])
where
ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
ff funid xs env
| product (map Set.size ys) == count =
case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of
(env,args) -> addProduction env cat (PApply funid args)
| otherwise = List.foldl (\env args -> addProduction env cat (PApply funid args)) env xs
where
count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
lindefCId = mkCId ("lindef "++showIdent (snd cat))
addRule lins (newCat', newArgs') env0 =
let [newCat] = getFIds env0 newCat'
(env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins))
in addLinDef env1 newCat funid
unfactor :: Term -> CnvMonad Term
unfactor t = CM (\gr c -> c (unfac gr t))
@@ -270,13 +306,13 @@ data Path
-- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index.
data ProtoFCat = PFCat Int Ident (Schema Identity Int (Int,[(Term,Int)]))
data ProtoFCat = PFCat [Ident] Ident Proto
type Env = (ProtoFCat, [ProtoFCat])
protoFCat :: GrammarEnv -> (Int,Cat) -> ProtoFCat
protoFCat (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) =
case IntMap.lookup n catSet >>= Map.lookup cat of
Just (_,_,pfcat) -> pfcat
protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat
protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) =
case Map.lookup cat catSet of
Just (_,_,proto) -> PFCat (map snd ctxt) cat proto
Nothing -> error "unknown category"
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
@@ -330,8 +366,9 @@ convertArg opts (Sort _) nr path = do
(args,_) <- get
let PFCat _ cat schema = args !! nr
l = index (reversePath path) schema
sym | isLiteralCat opts cat = SymLit nr l
| otherwise = SymCat nr l
sym | CProj (LVar i) CNil <- path = SymVar nr i
| isLiteralCat opts cat = SymLit nr l
| otherwise = SymCat nr l
return (CStr [sym])
where
index (CProj lbl path) (CRec rs) = case lookup lbl rs of
@@ -391,7 +428,7 @@ addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) ->
addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
in (env',(trm,b'))) env vs
in (env1,CTbl pt vs1)
addSequencesV env (CStr lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin)
in (env1,CStr seqid)
addSequencesV env (CPar i) = (env,CPar i)
@@ -441,25 +478,30 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd
----------------------------------------------------------------------
-- GrammarEnv
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production))
type CatSet = IntMap.IntMap (Map.Map Ident (FId,FId,ProtoFCat))
data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet
type Proto = Schema Identity Int (Int,[(Term,Int)])
type CatSet = Map.Map Ident (FId,FId,Proto)
type SeqSet = Map.Map Sequence SeqId
type FunSet = Map.Map CncFun FunId
type LinDefSet= IntMap.IntMap [FunId]
type CoerceSet= Map.Map [FId] FId
type AppSet = IntMap.IntMap (Set.Set (FunId,[FId]))
type ProdSet = IntMap.IntMap (Set.Set Production)
emptyGrammarEnv gr (m,mo) =
let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty
in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty
where
computeCatRange index cat ctype
| cat == cString = (index,(fidString,fidString,PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))])))
| cat == cInt = (index,(fidInt, fidInt, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))])))
| cat == cFloat = (index,(fidFloat, fidFloat, PFCat 0 cat (CRec [(theLinLabel,Identity (CStr 0))])))
| otherwise = (index+size,(index,index+size-1,PFCat 0 cat schema))
| cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))]))
| cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))]))
| cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))]))
| cat == cVar = (index,(fidFloat, fidFloat, CStr 0))
| otherwise = (index+size,(index,index+size-1,schema))
where
((_,size),schema) = compute (0,1) ctype
compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
in (st',(lbl,Identity t'))) st rs
in (st',CRec rs')
compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
@@ -478,96 +520,55 @@ emptyGrammarEnv gr (m,mo) =
Map.fromAscList
[(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)]
addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv
addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p =
GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet
expandHOAS opts (m,mo) env = return env {-
foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats)
where
hoTypes :: [(Int,CId)]
hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- Map.toList abs_defs
, (n,c) <- fst (typeSkeleton ty), n > 0]
-- add a range of PMCFG categories for each GF high-order category
add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) =
case IntMap.lookup 0 catSet >>= Map.lookup cat of
Just (start,end,ms,lbls) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms,lbls)) catSet
!last_id' = last_id+(end-start)+1
in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet)
Nothing -> env
-- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat
add_hoFun env (n,cat) =
let linRec = [[SymCat 0 i] | i <- case arg of {PFCat _ _ rcs _ -> [0..length rcs-1]}] ++
[[SymLit i 0] | i <- [1..n]]
(env1,lins) = List.mapAccumL addFSeq env linRec
newLinRec = mkArray lins
(env2,funid) = addCncFun env1 (CncFun _B newLinRec)
env3 = foldl (\env (arg,res) -> addProduction env res (PApply funid (arg : replicate n fcatVar)))
env2
(zip (getFIds env2 arg) (getFIds env2 res))
in env3
where
(arg,res) = case Map.lookup cat lincats of
Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> (protoFCat (0,cat) ctype, protoFCat (n,cat) ctype)
-- add one PMCFG function for each high-order category: _V : Var -> Cat
add_varFun env cat =
case Map.lookup cat lindefs of
Nothing -> return env
Just lindef -> convertRule opts env (PFRule _V [(0,cVar)] (0,cat) [arg] res lindef)
where
arg =
case Map.lookup cVar lincats of
Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> ctype
res =
case Map.lookup cat lincats of
Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> ctype
-}
addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p =
GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p =
GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
addFSeq :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst =
addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst =
case Map.lookup seq seqSet of
Just id -> (env,id)
Nothing -> let !last_seq = Map.size seqSet
in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq)
in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq)
where
seq = mkArray lst
addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
addCncFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun =
addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun =
case Map.lookup fun funSet of
Just id -> (env,id)
Nothing -> let !last_funid = Map.size funSet
in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid)
in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid)
addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId)
addCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats =
addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats =
case sub_fcats of
[fcat] -> (env,fcat)
_ -> case Map.lookup sub_fcats crcSet of
Just fcat -> (env,fcat)
Nothing -> let !fcat = last_id+1
in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat)
in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat)
addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv
addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid =
GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet
getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
Concr { cflags = flags
, printnames = printnames
, cncfuns = mkSetArray funSet
, lindefs = lindefSet
, sequences = mkSetArray seqSet
, productions = IntMap.union prodSet coercions
, pproductions = IntMap.empty
, lproductions = Map.empty
, cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))))
| (cat,(start,end,PFCat _ _ schema)) <- maybe [] Map.toList (IntMap.lookup 0 catSet)]
| (cat,(start,end,schema)) <- Map.toList catSet]
, totalCats = last_id+1
}
where
@@ -585,8 +586,8 @@ getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSe
getFIds :: GrammarEnv -> ProtoFCat -> [FId]
getFIds (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) =
case IntMap.lookup n catSet >>= Map.lookup cat of
getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) =
case Map.lookup cat catSet of
Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
where
variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
@@ -611,9 +612,9 @@ restrictHead path term = do
put (head, args)
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
restrictProtoFCat path v (PFCat n cat schema) = do
restrictProtoFCat path v (PFCat ctxt cat schema) = do
schema <- addConstraint path v schema
return (PFCat n cat schema)
return (PFCat ctxt cat schema)
where
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs
addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs

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

@@ -71,19 +71,22 @@ children :: JS.Ident
children = JS.Ident "cs"
frule2js :: Production -> JS.Expr
frule2js (PApply funid args) = new "Rule" [JS.EInt funid, JS.EArray (map JS.EInt args)]
frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)]
frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg]
farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))]
seq2js :: Array.Array DotPos Symbol -> JS.Expr
seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
sym2js :: Symbol -> JS.Expr
sym2js (SymCat n l) = new "Arg" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "Lit" [JS.EInt n, JS.EInt l]
sym2js (SymKS ts) = new "KS" (map JS.EStr ts)
sym2js (SymKP ts alts) = new "KP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)]
sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l]
sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l]
sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l]
sym2js (SymKS ts) = new "SymKS" (map JS.EStr ts)
sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map JS.EStr ts), JS.EArray (map alt2js alts)]
alt2js (Alt ps ts) = new "Alt" [JS.EArray (map JS.EStr ps), JS.EArray (map JS.EStr ts)]

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

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

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
containsLiterals :: Array DotPos Symbol -> Bool
containsLiterals row = any isPredefFId [args!!n | SymCat n _ <- Array.elems row] ||
not (null [n | SymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
-- The first line is for backward compat.
containsLiterals row = not (null ([n | SymLit n _ <- Array.elems row] ++
[n | SymVar n _ <- Array.elems row]))
symbolToCFSymbol :: Symbol -> [CFSymbol]
symbolToCFSymbol (SymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
symbolToCFSymbol (SymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
symbolToCFSymbol (SymCat n l) = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)]
symbolToCFSymbol (SymKS ts) = map Terminal ts
symbolToCFSymbol (SymKP ts as) = map Terminal $ ts
---- ++ [t | Alt ss _ <- as, t <- ss]

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

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

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

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

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

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

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 Data.Maybe
import Data.List
import Data.Array.IArray
import Text.PrettyPrint
-- operations for manipulating PGF grammars and objects
@@ -132,9 +133,6 @@ cidInt = mkCId "Int"
cidFloat = mkCId "Float"
cidVar = mkCId "__gfVar"
_B = mkCId "__gfB"
_V = mkCId "__gfV"
-- Utilities for doing linearization
@@ -162,7 +160,7 @@ data BracketedTokn
| Bracket_ CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex [Expr] [BracketedTokn] -- Invariant: the list is not empty
deriving Eq
type LinTable = Array.Array LIndex [BracketedTokn]
type LinTable = ([CId],Array.Array LIndex [BracketedTokn])
-- | Renders the bracketed string as string where
-- the brackets are shown as @(S ...)@ where
@@ -191,6 +189,34 @@ untokn nw (Bracket_ cat fid index es bss) =
let (nw',bss') = mapAccumR untokn nw bss
in (nw',[Bracket cat fid index es (concat bss')])
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,[Expr],LinTable)] -> LinTable
mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq filter (elems (sequences cnc ! seqid)) args | seqid <- elems lins])
where
(CncFun _ lins) = cncfuns cnc ! funid
computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,[Expr],LinTable)] -> [BracketedTokn]
computeSeq filter seq args = concatMap compute seq
where
compute (SymCat d r) = getArg d r
compute (SymLit d r) = getArg d r
compute (SymVar d r) = getVar d r
compute (SymKS ts) = [LeafKS ts]
compute (SymKP ts alts) = [LeafKP ts alts]
getArg d r
| not (null arg_lin) &&
filter ct = [Bracket_ cat fid r es arg_lin]
| otherwise = arg_lin
where
arg_lin = lin ! r
(ct@(cat,fid),es,(xs,lin)) = args !! d
getVar d r = [LeafKS [showCId (xs !! r)]]
where
(ct,es,(xs,lin)) = args !! d
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]
flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss

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

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

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

@@ -28,7 +28,7 @@ import PGF.Data
import PGF.Expr(Tree)
import PGF.Macros
import PGF.TypeCheck
import PGF.Forest(Forest(Forest), linearizeWithBrackets, foldForest)
import PGF.Forest(Forest(Forest), linearizeWithBrackets, getAbsTrees, foldForest)
-- | The input to the parser is a pair of predicates. The first one
-- 'piToken' checks that a given token, suggested by the grammar,
@@ -50,6 +50,7 @@ data ParseOutput
-- if there are many analizes for some phrase but they all are not type correct.
| ParseOk [Tree] -- ^ If the parsing and the type checkeing are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
parse :: PGF -> Language -> Type -> [Token] -> (ParseOutput,BracketedString)
parse pgf lang typ toks = loop (initState pgf lang typ) toks
@@ -108,7 +109,7 @@ simpleParseInput t = ParseInput (==t) (matchLit t)
_ -> Nothing }
| fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]);
_ -> Nothing }
| fid == fidVar = Just (cidVar,EFun (mkCId t),[t])
| fid == fidVar = Just (wildCId,EFun (mkCId t),[t])
| otherwise = Nothing
mkParseInput :: PGF -> Language -> (a -> Token -> Bool) -> [(CId,a -> Maybe (Tree,[Token]))] -> a -> ParseInput
@@ -140,7 +141,7 @@ nextState (PState pgf cnc chart items) input =
let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
acc = TMap.unions [tmap | (t,tmap) <- Map.toList map_items, piToken input t]
(acc1,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart
(acc1,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda acc chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
@@ -166,7 +167,7 @@ getCompletions (PState pgf cnc chart items) w =
let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
(acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart
(acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda acc chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
@@ -184,7 +185,7 @@ recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState)
recoveryStates open_types (EState pgf cnc chart) =
let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart)
(acc,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda Map.empty chart
(acc,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda Map.empty chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
@@ -200,7 +201,7 @@ recoveryStates open_types (EState pgf cnc chart) =
foldl (Set.fold (\(Active j' ppos funid seqid args keyc) ->
(:) (Active j' (ppos+1) funid seqid args keyc)))
items
[set | fcat <- open_fcats, set <- lookupACByFCat fcat ac]
[set | fcat <- open_fcats, (set,_) <- lookupACByFCat fcat ac]
flit _ = Nothing
ftok (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
@@ -212,26 +213,24 @@ recoveryStates open_types (EState pgf cnc chart) =
getParseOutput :: ParseState -> Type -> (ParseOutput,BracketedString)
getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) =
let froots | null roots = getPartialSeq (sequences cnc) (reverse (active chart1 : actives chart1)) seq
| otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots]
| otherwise = [([SymCat 0 lbl],[PArg [] fid]) | AK fid lbl <- roots]
bs = linearizeWithBrackets (Forest (abstract pgf) cnc (forest chart1) froots)
exps = nubsort $ do
(AK fid lbl) <- roots
(fvs,e) <- go Set.empty 0 (0,fid)
guard (Set.null fvs)
Right e1 <- [checkExpr pgf e ty]
return e1
res = if null exps
then ParseFailed (offset chart)
else ParseOk exps
f = Forest (abstract pgf) cnc (forest chart1) froots
bs = linearizeWithBrackets f
res | not (null es) = ParseOk es
| not (null errs) = TypeError errs
| otherwise = ParseIncomplete
where xs = [getAbsTrees f (PArg [] fid) (Just ty) | (AK fid lbl) <- roots]
es = concat [es | Right es <- xs]
errs = concat [errs | Left errs <- xs]
in (res,bs)
where
(mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
(acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda (TMap.compose Nothing acc) chart
(acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) (lindefs cnc) agenda (TMap.compose Nothing acc) chart
seq = [(j,cutAt ppos toks seqid,args,key) | (toks,set) <- TMap.toList acc', Active j ppos funid seqid args key <- Set.toList set]
flit _ = Nothing
@@ -255,32 +254,6 @@ getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) =
return (AK fid lbl)
Nothing -> mzero
go rec_ fcat' (d,fcat)
| fcat < totalCats cnc = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments
| Set.member fcat rec_ = mzero
| otherwise = foldForest (\funid args trees ->
do let CncFun fn lins = cncfuns cnc ! funid
args <- mapM (go (Set.insert fcat rec_) fcat) (zip [0..] args)
check_ho_fun fn args
`mplus`
trees)
(\const _ trees ->
return (freeVar const,const)
`mplus`
trees)
[] fcat (forest chart1)
check_ho_fun fun args
| fun == _V = return (head args)
| fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args))
| otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args)
mkVar (EFun v) = v
mkVar (EMeta _) = wildCId
freeVar (EFun v) = Set.singleton v
freeVar _ = Set.empty
getPartialSeq seqs actives = expand Set.empty
where
expand acc [] =
@@ -291,72 +264,99 @@ getPartialSeq seqs actives = expand Set.empty
where
acc' = Set.insert item acc
items' = case lookupAC key (actives !! j) of
Nothing -> items
Just set -> [if j' < j
then let lin' = take ppos (elems (unsafeAt seqs seqid))
in (j',lin'++map (inc (length args')) lin,args'++args,key')
else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items
Nothing -> items
Just (set,_) -> [if j' < j
then let lin' = take ppos (elems (unsafeAt seqs seqid))
in (j',lin'++map (inc (length args')) lin,args'++args,key')
else (j',lin,args,key') | Active j' ppos funid seqid args' key' <- Set.toList set] ++ items
inc n (SymCat d r) = SymCat (n+d) r
inc n (SymVar d r) = SymVar (n+d) r
inc n (SymLit d r) = SymLit (n+d) r
inc n s = s
process flit ftok !seqs !funs [] acc chart = (acc,chart)
process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart
process flit ftok !seqs !funs defs [] acc chart = (acc,chart)
process flit ftok !seqs !funs defs (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos =
case unsafeAt lin ppos of
SymCat d r -> let !fid = args !! d
SymCat d r -> let PArg hypos !fid = args !! d
key = AK fid r
items2 = case lookupPC (mkPK key k) (passive chart) of
Nothing -> items
Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items
Just id -> (Active j (ppos+1) funid seqid (updateAt d (PArg hypos id) args) key0) : items
items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items)
(\_ _ items -> items)
items2 fid (forest chart)
items2 fid (IntMap.unionWith Set.union new_sc (forest chart))
new_sc = foldl uu parent_sc hypos
parent_sc = case lookupAC key0 ((active chart : actives chart) !! (k-j)) of
Nothing -> IntMap.empty
Just (set,sc) -> sc
in case lookupAC key (active chart) of
Nothing -> process flit ftok seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}
Just set | Set.member item set -> process flit ftok seqs funs items acc chart
| otherwise -> process flit ftok seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
Nothing -> process flit ftok seqs funs defs items3 acc chart{active=insertAC key (Set.singleton item,new_sc) (active chart)}
Just (set,sc) | Set.member item set -> process flit ftok seqs funs defs items acc chart
| otherwise -> process flit ftok seqs funs defs items2 acc chart{active=insertAC key (Set.insert item set,IntMap.unionWith Set.union new_sc sc) (active chart)}
SymKS toks -> let !acc' = ftok toks (Active j (ppos+1) funid seqid args key0) acc
in process flit ftok seqs funs items acc' chart
in process flit ftok seqs funs defs items acc' chart
SymKP strs vars
-> let !acc' = foldl (\acc toks -> ftok toks (Active j (ppos+1) funid seqid args key0) acc) acc
(strs:[strs' | Alt strs' _ <- vars])
in process flit ftok seqs funs items acc' chart
SymLit d r -> let fid = args !! d
in process flit ftok seqs funs defs items acc' chart
SymLit d r -> let PArg hypos fid = args !! d
key = AK fid r
!fid' = case lookupPC (mkPK key k) (passive chart) of
Nothing -> fid
Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of
(toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
in process flit ftok seqs funs items acc' chart
(toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc
in process flit ftok seqs funs defs items acc' chart
[] -> case flit fid of
Just (cat,lit,toks)
-> let fid' = nextId chart
!acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
in process flit ftok seqs funs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> process flit ftok seqs funs items acc chart{active=insertAC key (Set.singleton item) (active chart)}
!acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg hypos fid') args) key0) acc
in process flit ftok seqs funs defs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> process flit ftok seqs funs defs items acc chart
SymVar d r -> let PArg hypos fid0 = args !! d
(fid1,fid2) = hypos !! r
key = AK fid1 0
!fid' = case lookupPC (mkPK key k) (passive chart) of
Nothing -> fid1
Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of
(toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc
in process flit ftok seqs funs defs items acc' chart
[] -> case flit fid1 of
Just (cat,lit,toks)
-> let fid' = nextId chart
!acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d (PArg (updateAt r (fid',fid2) hypos) fid0) args) key0) acc
in process flit ftok seqs funs defs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> process flit ftok seqs funs defs items acc chart
| otherwise =
case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart
items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of
Nothing -> items
Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set
in process flit ftok seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)
,nextId =nextId chart+1
}
Nothing -> items
Just (set,sc) -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
PArg hypos _ = args !! d
in (:) (Active j' (ppos+1) funid seqid (updateAt d (PArg hypos fid) args) keyc)) items set
in process flit ftok seqs funs defs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)
,nextId =nextId chart+1
}
Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items
in process flit ftok seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
in process flit ftok seqs funs defs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
where
!lin = unsafeAt seqs seqid
!k = offset chart
@@ -367,6 +367,10 @@ process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items)
where
CncFun _ lins = unsafeAt funs funid
uu forest (fid1,fid2) =
case IntMap.lookup fid2 defs of
Just funs -> foldl (\forest funid -> IntMap.insertWith Set.union fid2 (Set.singleton (PApply funid [PArg [] fid1])) forest) forest funs
Nothing -> forest
updateAt :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
@@ -381,22 +385,22 @@ data Active
{-# UNPACK #-} !DotPos
{-# UNPACK #-} !FunId
{-# UNPACK #-} !SeqId
[FId]
[PArg]
{-# UNPACK #-} !ActiveKey
deriving (Eq,Show,Ord)
data ActiveKey
= AK {-# UNPACK #-} !FId
{-# UNPACK #-} !LIndex
deriving (Eq,Ord,Show)
type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active))
type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active, IntMap.IntMap (Set.Set Production)))
emptyAC :: ActiveChart
emptyAC = IntMap.empty
lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active)
lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active, IntMap.IntMap (Set.Set Production))
lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l
lookupACByFCat :: FId -> ActiveChart -> [Set.Set Active]
lookupACByFCat :: FId -> ActiveChart -> [(Set.Set Active, IntMap.IntMap (Set.Set Production))]
lookupACByFCat fcat chart =
case IntMap.lookup fcat chart of
Nothing -> []
@@ -408,7 +412,7 @@ labelsAC fcat chart =
Nothing -> []
Just map -> IntMap.keys map
insertAC :: ActiveKey -> Set.Set Active -> ActiveChart -> ActiveChart
insertAC :: ActiveKey -> (Set.Set Active, IntMap.IntMap (Set.Set Production)) -> ActiveChart -> ActiveChart
insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart

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

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

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
import PGF.Data
@@ -65,7 +73,7 @@ scopeSize (Scope gamma) = length gamma
type MetaStore = IntMap MetaValue
data MetaValue
= MUnbound Scope [Expr -> TcM ()]
= MUnbound Scope TType [Expr -> TcM ()]
| MBound Expr
| MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved
-- to unlock this meta variable
@@ -96,9 +104,9 @@ lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of
Just (ty,_,_) -> Ok ms (TTyp [] ty)
Nothing -> Fail (UnknownFun fun))
newMeta :: Scope -> TcM MetaId
newMeta scope = TcM (\abstr ms -> let metaid = IntMap.size ms + 1
in Ok (IntMap.insert metaid (MUnbound scope []) ms) metaid)
newMeta :: Scope -> TType -> TcM MetaId
newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1
in Ok (IntMap.insert metaid (MUnbound scope tty []) ms) metaid)
newGuardedMeta :: Expr -> TcM MetaId
newGuardedMeta e = TcM (\abstr ms -> let metaid = IntMap.size ms + 1
@@ -115,7 +123,7 @@ lookupMeta ms i =
Just (MBound t) -> Just t
Just (MGuarded t _ x) | x == 0 -> Just t
| otherwise -> Nothing
Just (MUnbound _ _) -> Nothing
Just (MUnbound _ _ _) -> Nothing
Nothing -> Nothing
tcError :: TcError -> TcM a
@@ -125,7 +133,7 @@ addConstraint :: MetaId -> MetaId -> Env -> [Value] -> (Value -> TcM ()) -> TcM
addConstraint i j env vs c = do
mv <- getMeta j
case mv of
MUnbound scope cs -> addRef >> setMeta j (MUnbound scope ((\e -> release >> apply env e vs >>= c) : cs))
MUnbound scope tty cs -> addRef >> setMeta j (MUnbound scope tty ((\e -> release >> apply env e vs >>= c) : cs))
MBound e -> apply env e vs >>= c
MGuarded e cs x | x == 0 -> apply env e vs >>= c
| otherwise -> addRef >> setMeta j (MGuarded e ((\e -> release >> apply env e vs >>= c) : cs) x)
@@ -162,6 +170,8 @@ data TcError
| CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression.
| UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking.
| UnexpectedImplArg [CId] Expr -- ^ Implicit argument was passed where the type doesn't allow it
| UnsolvableGoal [CId] MetaId Type -- ^ There is a goal that cannot be solved
deriving Eq
-- | Renders the type checking error to a document. See 'Text.PrettyPrint'.
ppTcError :: TcError -> Doc
@@ -177,6 +187,8 @@ ppTcError (CannotInferType xs e) = text "Cannot infer the type of expressi
ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$
text "in the expression:" <+> ppExpr 0 xs e
ppTcError (UnexpectedImplArg xs e) = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here"
ppTcError (UnsolvableGoal xs metaid ty)= text "The goal:" <+> ppMeta metaid <+> colon <+> ppType 0 xs ty $$
text "cannot be solved"
-----------------------------------------------------
-- checkType
@@ -223,7 +235,7 @@ tcCatArgs scope (EImplArg e:es) delta ((Implicit,x,ty):hs) ty0 n m = do
tcCatArgs scope es (v:delta) hs ty0 n m
return (delta,EImplArg e:es)
tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do
i <- newMeta scope
i <- newMeta scope (TTyp delta ty)
(delta,es) <- if x == wildCId
then tcCatArgs scope es delta hs ty0 n m
else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : delta) hs ty0 n m
@@ -281,7 +293,7 @@ tcExpr scope e0@(EAbs Explicit x e) tty =
_ -> do ty <- evalType (scopeSize scope) tty
tcError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope (EMeta _) tty = do
i <- newMeta scope
i <- newMeta scope tty
return (EMeta i)
tcExpr scope e0 tty = do
(e0,tty0) <- infExpr scope e0
@@ -352,7 +364,7 @@ tcArg scope e1 e2 delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = do
else do v2 <- eval (scopeEnv scope) e2
return (EApp e1 e2,v2:delta,DTyp hs c es)
tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do
i <- newMeta scope
i <- newMeta scope (TTyp delta ty)
if x == wildCId
then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es)
else tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 (VMeta i (scopeEnv scope) [] : delta) (DTyp hs c es)
@@ -402,7 +414,7 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2
MBound e -> apply env e vs
MGuarded e _ x | x == 0 -> apply env e vs
| otherwise -> return v
MUnbound _ _ -> return v
MUnbound _ _ _ -> return v
deRef v = return v
eqValue' k (VSusp i env vs1 c) v2 = addConstraint i0 i env vs1 (\v1 -> eqValue k (c v1) v2)
@@ -410,15 +422,15 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2
eqValue' k (VMeta i env1 vs1) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2
eqValue' k (VMeta i env1 vs1) v2 = do mv <- getMeta i
case mv of
MUnbound scopei cs -> do e2 <- mkLam i scopei env1 vs1 v2
setMeta i (MBound e2)
sequence_ [c e2 | c <- cs]
MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env1 e vs1 >>= \v1 -> eqValue' k v1 v2) : cs) x)
MUnbound scopei _ cs -> do e2 <- mkLam i scopei env1 vs1 v2
setMeta i (MBound e2)
sequence_ [c e2 | c <- cs]
MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env1 e vs1 >>= \v1 -> eqValue' k v1 v2) : cs) x)
eqValue' k v1 (VMeta i env2 vs2) = do mv <- getMeta i
case mv of
MUnbound scopei cs -> do e1 <- mkLam i scopei env2 vs2 v1
setMeta i (MBound e1)
sequence_ [c e1 | c <- cs]
MUnbound scopei _ cs -> do e1 <- mkLam i scopei env2 vs2 v1
setMeta i (MBound e1)
sequence_ [c e1 | c <- cs]
MGuarded e cs x -> setMeta i (MGuarded e ((\e -> apply env2 e vs2 >>= \v2 -> eqValue' k v1 v2) : cs) x)
eqValue' k (VApp f1 vs1) (VApp f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2
eqValue' k (VConst f1 vs1) (VConst f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2
@@ -452,11 +464,11 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2
else return ()
mv <- getMeta i
case mv of
MBound e -> apply env e vs >>= occurCheck i0 k xs
MGuarded e _ _ -> apply env e vs >>= occurCheck i0 k xs
MUnbound scopei _ | scopeSize scopei > k -> raiseTypeMatchError
| otherwise -> do vs <- mapM (occurCheck i0 k xs) vs
return (VMeta i env vs)
MBound e -> apply env e vs >>= occurCheck i0 k xs
MGuarded e _ _ -> apply env e vs >>= occurCheck i0 k xs
MUnbound scopei _ _ | scopeSize scopei > k -> raiseTypeMatchError
| otherwise -> do vs <- mapM (occurCheck i0 k xs) vs
return (VMeta i env vs)
occurCheck i0 k xs (VSusp i env vs cnt) = do addConstraint i0 i env vs (\v -> occurCheck i0 k xs (cnt v) >> return ())
return (VSusp i env vs cnt)
occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of
@@ -480,7 +492,7 @@ checkResolvedMetaStore scope e = TcM (\abstr ms ->
then Ok ms ()
else Fail (UnresolvedMetaVars (scopeVars scope) e xs))
where
isResolved (MUnbound _ []) = True
isResolved (MUnbound _ _ []) = True
isResolved (MGuarded _ _ _) = True
isResolved (MBound _) = True
isResolved _ = False

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.Expr (showExpr, Tree)
import PGF.Linearize
import PGF.Macros (lookValCat, lookMap, _B, _V,
import PGF.Macros (lookValCat, lookMap,
BracketedString(..), BracketedTokn(..), flattenBracketedString)
import qualified Data.Map as Map
@@ -286,17 +286,14 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
lin0 path xs ys mb_fid (EAbs _ x e) = lin0 path (showCId x:xs) ys mb_fid e
lin0 path xs ys mb_fid (ETyped e _) = lin0 path xs ys mb_fid e
lin0 path xs ys mb_fid e | null xs = lin path ys mb_fid e []
| otherwise = apply path (xs ++ ys) mb_fid _B (e:[ELit (LStr x) | x <- xs])
lin0 path xs ys mb_fid e = lin path ys mb_fid e []
lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es)
lin path xs mb_fid (ELit l) [] = case l of
LStr s -> return (mark Nothing path (ss s))
LInt n -> return (mark Nothing path (ss (show n)))
LFlt f -> return (mark Nothing path (ss (show f)))
lin path xs mb_fid (EMeta i) es = apply path xs mb_fid _V (ELit (LStr ('?':show i)):es)
lin path xs mb_fid (EFun f) es = map (mark (Just f) path) (apply path xs mb_fid f es)
lin path xs mb_fid (EVar i) es = apply path xs mb_fid _V (ELit (LStr (xs !! i)) :es)
lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
@@ -308,21 +305,16 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e
Just set -> do prod <- Set.toList set
case prod of
PApply funid fids -> do guard (length fids == length es)
args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
args <- sequence (zipWith3 (\i (PArg _ fid) e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
let (CncFun _ lins) = cncfuns cnc ! funid
return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
PCoerce fid -> apply path xs (Just fid) f es
Nothing -> mzero
Nothing -> apply path xs mb_fid _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
where
lookupProds (Just fid) prods = IntMap.lookup fid prods
lookupProds Nothing prods
| f == _B || f == _V = Nothing
| otherwise = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
lookupProds Nothing prods = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
sub i path
| f == _B || f == _V = path
| otherwise = i:path
sub i path = i:path
isApp (PApply _ _) = True
isApp _ = False

1
src/server/PGFService.hs
View File

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