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

bug fix for bracketedLinearize with HOAS and meta variables

Browse Source
This commit is contained in:
krasimir
2010-05-01 20:51:07 +00:00
parent 9fe715a58d
commit a587cfef40
1 changed files with 49 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -38,6 +38,9 @@ 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 "" . (!0)) . linTree pgf lang
where
head [] = error "cannot linearize"
head (bs:bss) = bs
-- | 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
@@ -56,58 +59,64 @@ tabularLinearizes pgf lang e = map (zip lbls . map (unwords . concatMap flattenB
-- Implementation -- 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 -> [Array LIndex BracketedTokn]
linTree pgf lang e = linTree pgf lang e =
[amapWithIndex (\label -> Bracket_ fid label cat) lin | (_,(fid,cat,lin)) <- lin0 [] [] Nothing 0 e] [amapWithIndex (\label -> Bracket_ fid label cat) lin | (_,((cat,fid),lin)) <- lin0 [] [] Nothing 0 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_fid n_fid (EAbs _ x e) = lin0 (showCId x:xs) ys mb_fid n_fid e lin0 xs ys mb_cty n_fid (EAbs _ x e) = lin0 (showCId x:xs) ys mb_cty n_fid e
lin0 xs ys mb_fid n_fid (ETyped e _) = lin0 xs ys mb_fid n_fid e lin0 xs ys mb_cty n_fid (ETyped e _) = lin0 xs ys mb_cty n_fid e
lin0 xs ys mb_fid n_fid e | null xs = lin ys mb_fid n_fid e [] lin0 xs ys mb_cty n_fid e | null xs = lin ys mb_cty n_fid e []
| otherwise = apply (xs ++ ys) mb_fid n_fid _B (e:[ELit (LStr x) | x <- xs]) | otherwise = apply (xs ++ ys) mb_cty n_fid _B (e:[ELit (LStr x) | x <- xs])
lin xs mb_fid n_fid (EApp e1 e2) es = lin xs mb_fid n_fid e1 (e2:es) lin xs mb_cty n_fid (EApp e1 e2) es = lin xs mb_cty n_fid e1 (e2:es)
lin xs mb_fid n_fid (ELit l) [] = case l of lin xs mb_cty n_fid (ELit l) [] = case l of
LStr s -> return (n_fid+1,(n_fid,cidString,ss s)) LStr s -> return (n_fid+1,((cidString,n_fid),ss s))
LInt n -> return (n_fid+1,(n_fid,cidInt ,ss (show n))) LInt n -> return (n_fid+1,((cidInt, n_fid),ss (show n)))
LFlt f -> return (n_fid+1,(n_fid,cidFloat ,ss (show f))) LFlt f -> return (n_fid+1,((cidFloat, n_fid),ss (show f)))
lin xs mb_fid n_fid (EMeta i) es = apply xs mb_fid n_fid _V (ELit (LStr ('?':show i)):es) lin xs mb_cty n_fid (EMeta i) es = apply xs mb_cty n_fid _V (ELit (LStr ('?':show i)):es)
lin xs mb_fid n_fid (EFun f) es = apply xs mb_fid n_fid f es lin xs mb_cty n_fid (EFun f) es = apply xs mb_cty n_fid f es
lin xs mb_fid n_fid (EVar i) es = apply xs mb_fid n_fid _V (ELit (LStr (xs !! i)) :es) lin xs mb_cty n_fid (EVar i) es = apply xs mb_cty n_fid _V (ELit (LStr (xs !! i)) :es)
lin xs mb_fid n_fid (ETyped e _) es = lin xs mb_fid n_fid e es lin xs mb_cty n_fid (ETyped e _) es = lin xs mb_cty n_fid e es
lin xs mb_fid n_fid (EImplArg e) es = lin xs mb_fid n_fid e es lin xs mb_cty n_fid (EImplArg e) es = lin xs mb_cty n_fid e es
ss s = listArray (0,0) [[LeafKS [s]]] ss s = listArray (0,0) [[LeafKS [s]]]
apply :: [String] -> Maybe FId -> FId -> CId -> [Expr] -> [(FId,(FId, CId, LinTable))] apply :: [String] -> Maybe CncType -> FId -> CId -> [Expr] -> [(FId,(CncType, LinTable))]
apply xs mb_fid n_fid f es = apply xs mb_cty n_fid f es =
case Map.lookup f lp of case Map.lookup f lp of
Just prods -> do prod <- lookupProds mb_fid prods Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
case prod of guard (length ctys == length es)
PApply funid fids -> do guard (length fids == length es) (n_fid,args) <- descend n_fid (zip ctys es)
(n_fid,args) <- descend n_fid (zip fids es) let (CncFun _ lins) = cncfuns cnc ! funid
let (CncFun fun lins) = cncfuns cnc ! funid return (n_fid+1,((cat,n_fid),listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]))
Just (DTyp _ cat _,_,_) = Map.lookup fun (funs (abstract pgf)) Nothing -> apply xs mb_cty n_fid _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
return (n_fid+1,(n_fid,cat,listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]))
PCoerce fid -> apply xs (Just fid) n_fid f es
Nothing -> apply xs mb_fid n_fid _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
where where
lookupProds (Just fid) prods = maybe [] Set.toList (IntMap.lookup fid prods) getApps prods =
lookupProds Nothing prods case mb_cty of
| f == _B || f == _V = [] Just cty@(cat,fid) -> maybe [] (concatMap (toApp cty) . Set.toList) (IntMap.lookup fid prods)
| otherwise = [prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] Nothing | f == _B
|| f == _V -> []
| otherwise -> concat [toApp (wildCId,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))
descend n_fid [] = return (n_fid,[]) descend n_fid [] = return (n_fid,[])
descend n_fid ((fid,e):fes) = do (n_fid,xx) <- lin0 [] xs (Just fid) n_fid e descend n_fid (((cat,fid),e):fes) = do (n_fid,arg) <- lin0 [] xs (Just (cat,fid)) n_fid e
(n_fid,xxs) <- descend n_fid fes (n_fid,args) <- descend n_fid fes
return (n_fid,xx:xxs) return (n_fid,arg:args)
isApp (PApply _ _) = True computeSeq :: SeqId -> [(CncType,LinTable)] -> [BracketedTokn]
isApp _ = False
computeSeq :: SeqId -> [(FId,CId,LinTable)] -> [BracketedTokn]
computeSeq seqid args = concatMap compute (elems seq) computeSeq seqid args = concatMap compute (elems seq)
where where
seq = sequences cnc ! seqid seq = sequences cnc ! seqid
@@ -121,8 +130,8 @@ linTree pgf lang e =
| not (null arg_lin) = [Bracket_ fid r cat arg_lin] | not (null arg_lin) = [Bracket_ fid r cat arg_lin]
| otherwise = arg_lin | otherwise = arg_lin
where where
arg_lin = lin ! r arg_lin = lin ! r
(fid,cat,lin) = args !! d ((cat,fid),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))