blob: 2d23e86533ad6119a9f5d0f4232d98c818a0aead (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
module PGF.Linearize where
import PGF.CId
import PGF.Data
import PGF.Macros
import qualified Data.Map as Map
import Data.List
import Debug.Trace
-- linearization and computation of concrete PGF Terms
linearize :: PGF -> CId -> Exp -> String
linearize pgf lang = realize . linExp pgf lang
realize :: Term -> String
realize trm = case trm of
R ts -> realize (ts !! 0)
S ss -> unwords $ map realize ss
K t -> case t of
KS s -> s
KP s _ -> unwords s ---- prefix choice TODO
W s t -> s ++ realize t
FV ts -> realize (ts !! 0) ---- other variants TODO
TM s -> s
_ -> "ERROR " ++ show trm ---- debug
linExp :: PGF -> CId -> Exp -> Term
linExp pgf lang = lin
where
lin (EAbs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
lin (EApp fun es) = comp (map lin es) $ look fun
lin (EStr s ) = R [kks (show s)] -- quoted
lin (EInt i ) = R [kks (show i)]
lin (EFloat d ) = R [kks (show d)]
lin (EVar x ) = TM (prCId x)
lin (EMeta i ) = TM (show i)
comp = compute pgf lang
look = lookLin pgf lang
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
|
