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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:54 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Simplistic GFC format
-----------------------------------------------------------------------------
module GF.OldParsing.SimpleGFC where
import qualified AbsGFC
import qualified Ident
import GF.Printing.PrintParser
import GF.Printing.PrintSimplifiedTerm
import Operations (ifNull)
----------------------------------------------------------------------
type Name = Ident.Ident
type Cat = Ident.Ident
type Constr = AbsGFC.CIdent
type Var = Ident.Ident
type Token = AbsGFC.Tokn
type Label = AbsGFC.Label
constr2name :: Constr -> Name
constr2name (AbsGFC.CIQ _ name) = name
----------------------------------------------------------------------
type Grammar = [Rule]
data Rule = Rule Name Typing (Maybe (Term, CType))
deriving (Eq, Ord, Show)
type Typing = (Type, [Decl])
data Decl = Var ::: Type
deriving (Eq, Ord, Show)
data Type = Cat :@ [Atom]
deriving (Eq, Ord, Show)
data Atom = ACon Constr
| AVar Var
deriving (Eq, Ord, Show)
data CType = RecT [(Label, CType)]
| TblT CType CType
| ConT Constr [Term]
| StrT
deriving (Eq, Ord, Show)
data Term = Arg Int Cat Path -- ^ argument variable, the 'Path' is a path
-- pointing into the term
| Constr :^ [Term] -- ^ constructor
| Rec [(Label, Term)] -- ^ record
| Term :. Label -- ^ record projection
| Tbl [(Term, Term)] -- ^ table of patterns\/terms
| Term :! Term -- ^ table selection
| Variants [Term] -- ^ variants
| Term :++ Term -- ^ concatenation
| Token Token -- ^ single token
| Empty -- ^ empty string
| Wildcard -- ^ wildcard pattern variable
| Var Var -- ^ bound pattern variable
-- Res CIdent -- resource identifier
-- Int Integer -- integer
deriving (Eq, Ord, Show)
----------------------------------------------------------------------
(+.) :: Term -> Label -> Term
Variants terms +. lbl = Variants $ map (+. lbl) terms
Rec record +. lbl = maybe err id $ lookup lbl record
where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl
Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
term +. lbl = term :. lbl
(+!) :: Term -> Term -> Term
Variants terms +! pat = Variants $ map (+! pat) terms
term +! Variants pats = Variants $ map (term +!) pats
Tbl table +! pat = maybe err id $ lookup pat table
where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat
Arg arg cat path +! pat = Arg arg cat (path ++! pat)
term +! pat = term :! pat
(?++) :: Term -> Term -> Term
Variants terms ?++ term = Variants $ map (?++ term) terms
term ?++ Variants terms = Variants $ map (term ?++) terms
Empty ?++ term = term
term ?++ Empty = term
term1 ?++ term2 = term1 :++ term2
----------------------------------------------------------------------
newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show)
emptyPath :: Path
emptyPath = Path []
(++.) :: Path -> Label -> Path
Path path ++. lbl = Path (Left lbl : path)
(++!) :: Path -> Term -> Path
Path path ++! sel = Path (Right sel : path)
----------------------------------------------------------------------
instance Print Rule where
prt (Rule name (typ, args) term)
= prt name ++ " : " ++
prtAfter " " args ++
(if null args then "" else "-> ") ++
prt typ ++
maybe "" (\(t,c) -> " := " ++ prt t ++ " : " ++ prt c) term ++
"\n"
prtList = concatMap prt
instance Print Decl where
prt (var ::: typ) = "(" ++ prt var ++ ":" ++ prt typ ++ ")"
instance Print Type where
prt (cat :@ ats) = prt cat ++ prtList ats
instance Print Atom where
prt (ACon con) = prt con
prt (AVar var) = "?" ++ prt var
instance Print CType where
prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
prt (ConT t ts) = prt t ++ "(|" ++ prtSep "|" ts ++ "|)"
prt (StrT) = "Str"
instance Print Term where
prt (Arg n c p) = prt c ++ "@" ++ prt n ++ prt p
prt (c :^ []) = prt c
prt (c :^ ts) = prt c ++ prtList ts
prt (Rec rec) = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
prt (Tbl tbl) = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "}"
prt (Variants ts) = "{| " ++ prtSep " | " ts ++ " |}"
prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
prt (Token t) = prt t
prt (Empty) = "[]"
prt (Wildcard) = "_"
prt (term :. lbl) = prt term ++ "." ++ prt lbl
prt (term :! sel) = prt term ++ " ! " ++ prt sel
prt (Var var) = "?" ++ prt var
instance Print Path where
prt (Path path) = concatMap prtEither (reverse path)
where prtEither (Left lbl) = "." ++ prt lbl
prtEither (Right patt) = "!" ++ prt patt
|
