mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-12 06:19:33 -06:00
160 lines
4.9 KiB
Haskell
160 lines
4.9 KiB
Haskell
module PGF.Linearize
|
|
(linearizes,realize,realizes,linTree, linTreeMark,linearizesMark) where
|
|
|
|
import PGF.CId
|
|
import PGF.Data
|
|
import PGF.Macros
|
|
import PGF.Tree
|
|
|
|
import Control.Monad
|
|
import qualified Data.Map as Map
|
|
import Data.List
|
|
|
|
import Debug.Trace
|
|
|
|
-- linearization and computation of concrete PGF Terms
|
|
|
|
linearizes :: PGF -> CId -> Expr -> [String]
|
|
linearizes pgf lang = realizes . linTree pgf lang
|
|
|
|
realize :: Term -> String
|
|
realize = concat . take 1 . realizes
|
|
|
|
realizes :: Term -> [String]
|
|
realizes = map (unwords . untokn) . realizest
|
|
|
|
realizest :: Term -> [[Tokn]]
|
|
realizest trm = case trm of
|
|
R ts -> realizest (ts !! 0)
|
|
S ss -> map concat $ combinations $ map realizest ss
|
|
K t -> [[t]]
|
|
W s t -> [[KS (s ++ r)] | [KS r] <- realizest t]
|
|
FV ts -> concatMap realizest ts
|
|
TM s -> [[KS s]]
|
|
_ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug
|
|
|
|
untokn :: [Tokn] -> [String]
|
|
untokn ts = case ts of
|
|
KP d _ : [] -> d
|
|
KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
|
|
KS s : ws -> s : untokn ws
|
|
[] -> []
|
|
where
|
|
sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
|
|
v:_ -> v
|
|
_ -> d
|
|
|
|
-- Lifts all variants to the top level (except those in macros).
|
|
liftVariants :: Term -> [Term]
|
|
liftVariants = f
|
|
where
|
|
f (R ts) = liftM R $ mapM f ts
|
|
f (P t1 t2) = liftM2 P (f t1) (f t2)
|
|
f (S ts) = liftM S $ mapM f ts
|
|
f (FV ts) = ts >>= f
|
|
f (W s t) = liftM (W s) $ f t
|
|
f t = return t
|
|
|
|
linTree :: PGF -> CId -> Expr -> Term
|
|
linTree pgf lang = lin . expr2tree
|
|
where
|
|
lin (Abs xs e ) = case lin e of
|
|
R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs)
|
|
TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs)
|
|
lin (Fun fun es) = let argVariants = mapM (liftVariants . lin) es
|
|
in variants [compute pgf lang args $ look fun | args <- argVariants]
|
|
lin (Lit (LStr s)) = R [kks (show s)] -- quoted
|
|
lin (Lit (LInt i)) = R [kks (show i)]
|
|
lin (Lit (LFlt d)) = R [kks (show d)]
|
|
lin (Var x) = TM (showCId x)
|
|
lin (Meta i) = TM (show i)
|
|
|
|
look = lookLin pgf lang
|
|
|
|
variants :: [Term] -> Term
|
|
variants ts = case ts of
|
|
[t] -> t
|
|
_ -> FV ts
|
|
|
|
unvariants :: Term -> [Term]
|
|
unvariants t = case t of
|
|
FV ts -> ts
|
|
_ -> [t]
|
|
|
|
compute :: PGF -> CId -> [Term] -> Term -> Term
|
|
compute pgf lang args = comp where
|
|
comp trm = case trm of
|
|
P r p -> proj (comp r) (comp p)
|
|
W s t -> W s (comp t)
|
|
R ts -> R $ map comp ts
|
|
V i -> idx args i -- already computed
|
|
F c -> comp $ look c -- not computed (if contains argvar)
|
|
FV ts -> FV $ map comp ts
|
|
S ts -> S $ filter (/= S []) $ map comp ts
|
|
_ -> trm
|
|
|
|
look = lookOper pgf lang
|
|
|
|
idx xs i = if i > length xs - 1
|
|
then trace
|
|
("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0
|
|
else xs !! i
|
|
|
|
proj r p = case (r,p) of
|
|
(_, FV ts) -> FV $ map (proj r) ts
|
|
(FV ts, _ ) -> FV $ map (\t -> proj t p) ts
|
|
(W s t, _) -> kks (s ++ getString (proj t p))
|
|
_ -> comp $ getField r (getIndex p)
|
|
|
|
getString t = case t of
|
|
K (KS s) -> s
|
|
_ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR"
|
|
|
|
getIndex t = case t of
|
|
C i -> i
|
|
TM _ -> 0 -- default value for parameter
|
|
_ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666
|
|
|
|
getField t i = case t of
|
|
R rs -> idx rs i
|
|
TM s -> TM s
|
|
_ -> error ("ERROR in grammar compiler: field from " ++ show t) t
|
|
|
|
---------
|
|
-- markup with tree positions
|
|
|
|
linearizesMark :: PGF -> CId -> Expr -> [String]
|
|
linearizesMark pgf lang = realizes . linTreeMark pgf lang
|
|
|
|
linTreeMark :: PGF -> CId -> Expr -> Term
|
|
linTreeMark pgf lang = lin [] . expr2tree
|
|
where
|
|
lin p (Abs xs e ) = case lin p e of
|
|
R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs)
|
|
TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs)
|
|
lin p (Fun fun es) =
|
|
let argVariants =
|
|
mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es)
|
|
in variants [mark (fun,p) $ compute pgf lang args $ look fun |
|
|
args <- argVariants]
|
|
lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted
|
|
lin p (Lit (LInt i)) = mark p $ R [kks (show i)]
|
|
lin p (Lit (LFlt d)) = mark p $ R [kks (show d)]
|
|
lin p (Var x) = mark p $ TM (showCId x)
|
|
lin p (Meta i) = mark p $ TM (show i)
|
|
|
|
look = lookLin pgf lang
|
|
|
|
mark :: Show a => a -> Term -> Term
|
|
mark p t = case t of
|
|
R ts -> R $ map (mark p) ts
|
|
FV ts -> R $ map (mark p) ts
|
|
S ts -> S $ bracket p ts
|
|
K s -> S $ bracket p [t]
|
|
W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts]
|
|
_ -> t
|
|
-- otherwise in normal form
|
|
|
|
bracket p ts = [kks ("("++show p)] ++ ts ++ [kks ")"]
|
|
sub p i = p ++ [i]
|