summaryrefslogtreecommitdiff
path: root/src/runtime/haskell/PGF/Linearize.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell/PGF/Linearize.hs')
-rw-r--r--src/runtime/haskell/PGF/Linearize.hs123
1 files changed, 54 insertions, 69 deletions
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 84b1b116f..1daeb50f6 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -23,7 +23,7 @@ import qualified Data.Set as Set
-- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String
-linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn "" . (!0)) . linTree pgf lang
+linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn "" . firstLin) . linTree pgf lang
-- | The same as 'linearizeAllLang' but does not return
-- the language.
@@ -37,101 +37,86 @@ linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concre
-- | Linearizes given expression as a bracketed string in the language
bracketedLinearize :: PGF -> Language -> Tree -> BracketedString
-bracketedLinearize pgf lang = head . concat . map (snd . untokn "" . (!0)) . linTree pgf lang
+bracketedLinearize pgf lang = head . concat . map (snd . untokn "" . firstLin) . linTree pgf lang
where
head [] = error "cannot linearize"
head (bs:bss) = bs
+firstLin (_,arr)
+ | inRange (bounds arr) 0 = arr ! 0
+ | otherwise = LeafKS []
+
-- | Creates a table from feature name to linearization.
-- The outher list encodes the variations
tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]]
-tabularLinearizes pgf lang e = map (zip lbls . map (unwords . concatMap flattenBracketedString . snd . untokn "") . elems)
- (linTree pgf lang e)
+tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
where
- lbls = case unApp e of
- Just (f,_) -> let cat = valCat (lookType pgf f)
- in case Map.lookup cat (cnccats (lookConcr pgf lang)) of
- Just (CncCat _ _ lbls) -> elems lbls
- Nothing -> error "No labels"
- Nothing -> error "Not function application"
+ cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn "") (elems lin)
+
+ lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
+ Just (CncCat _ _ lbls) -> elems lbls
+ Nothing -> error "No labels"
--------------------------------------------------------------------
-- Implementation
--------------------------------------------------------------------
-type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
-
-linTree :: PGF -> Language -> Expr -> [Array LIndex BracketedTokn]
+linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)]
linTree pgf lang e =
- nub [amapWithIndex (\label -> Bracket_ cat fid label [e]) lin | (_,((cat,fid),e,lin)) <- lin0 [] [] Nothing 0 e e]
+ nub [(ct,amapWithIndex (\label -> Bracket_ cat fid label es) lin) | (_,(ct@(cat,fid),es,(xs,lin))) <- lin Nothing 0 e [] [] e []]
where
cnc = lookMap (error "no lang") lang (concretes pgf)
lp = lproductions cnc
-
- lin0 xs ys mb_cty n_fid e0 (EAbs _ x e) = lin0 (showCId x:xs) ys mb_cty n_fid e0 e
- lin0 xs ys mb_cty n_fid e0 (ETyped e _) = lin0 xs ys mb_cty n_fid e0 e
- lin0 xs ys mb_cty n_fid e0 e | null xs = lin ys mb_cty n_fid e0 e []
- | otherwise = apply (xs ++ ys) mb_cty n_fid e0 _B (e:[ELit (LStr x) | x <- xs])
-
- lin xs mb_cty n_fid e0 (EApp e1 e2) es = lin xs mb_cty n_fid e0 e1 (e2:es)
- lin xs mb_cty n_fid e0 (ELit l) [] = case l of
- LStr s -> return (n_fid+1,((cidString,n_fid),e0,ss s))
- LInt n -> return (n_fid+1,((cidInt, n_fid),e0,ss (show n)))
- LFlt f -> return (n_fid+1,((cidFloat, n_fid),e0,ss (show f)))
- lin xs mb_cty n_fid e0 (EMeta i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr ('?':show i)):es)
- lin xs mb_cty n_fid e0 (EFun f) es = apply xs mb_cty n_fid e0 f es
- lin xs mb_cty n_fid e0 (EVar i) es = apply xs mb_cty n_fid e0 _V (ELit (LStr (xs !! i)) :es)
- lin xs mb_cty n_fid e0 (ETyped e _) es = lin xs mb_cty n_fid e0 e es
- lin xs mb_cty n_fid e0 (EImplArg e) es = lin xs mb_cty n_fid e0 e es
+
+ lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
+ lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es)
+ lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es
+ lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es
+ lin mb_cty n_fid e0 ys xs (EFun f) es = apply mb_cty n_fid e0 ys xs f es
+ lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i)
+ lin mb_cty n_fid e0 ys xs (EVar i) [] = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i))
+ lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of
+ LStr s -> return (n_fid+1,((cidString,n_fid),[e0],([],ss s)))
+ LInt n -> return (n_fid+1,((cidInt, n_fid),[e0],([],ss (show n))))
+ LFlt f -> return (n_fid+1,((cidFloat, n_fid),[e0],([],ss (show f))))
ss s = listArray (0,0) [[LeafKS [s]]]
- apply :: [String] -> Maybe CncType -> FId -> Expr -> CId -> [Expr] -> [(FId,(CncType, Expr, LinTable))]
- apply xs mb_cty n_fid e0 f es =
+ apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, [Expr], LinTable))]
+ apply mb_cty n_fid e0 ys xs f es =
case Map.lookup f lp of
Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
- guard (length ctys == length es)
(n_fid,args) <- descend n_fid (zip ctys es)
- let (CncFun _ lins) = cncfuns cnc ! funid
- return (n_fid+1,((cat,n_fid),e0,listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins]))
- Nothing -> apply xs mb_cty n_fid e0 _V [ELit (LStr ("[" ++ showCId f ++ "]"))] -- fun without lin
+ return (n_fid+1,((cat,n_fid),[e0],mkLinTable cnc (const True) xs funid args))
+ Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin
where
getApps prods =
case mb_cty of
- Just cty@(cat,fid) -> maybe [] (concatMap (toApp cty) . Set.toList) (IntMap.lookup fid prods)
- Nothing | f == _B
- || f == _V -> []
- | otherwise -> concat [toApp (wildCId,fid) prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
- 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 (((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)
-
- computeSeq :: SeqId -> [(CncType,Expr,LinTable)] -> [BracketedTokn]
- computeSeq seqid args = concatMap compute (elems seq)
+ 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
- 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
+ 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 ((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)
+
+ 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))
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:21:32 +0000