Parser.hs 8.18 KB
Newer Older
marton bognar's avatar
marton bognar committed
1
{-# OPTIONS_GHC -Wall #-}
Belpaire's avatar
Belpaire committed
2

3
-- parser mostly inspired by the inbound haskell parser
marton bognar's avatar
marton bognar committed
4
module Parser (pLanguage) where
Belpaire's avatar
Belpaire committed
5

marton bognar's avatar
marton bognar committed
6
import Data.List
marton bognar's avatar
marton bognar committed
7
8
9
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec.Token
Belpaire's avatar
Belpaire committed
10

marton bognar's avatar
marton bognar committed
11
import GeneralTerms
Belpaire's avatar
Belpaire committed
12

marton bognar's avatar
marton bognar committed
13
myDef :: LanguageDef st
Belpaire's avatar
Belpaire committed
14
myDef =
marton bognar's avatar
marton bognar committed
15
16
17
18
  haskellStyle
    { opStart = oneOf ":!#$%&*+./<=>?@\\^|-~,;"
    , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~,;"
    , reservedNames =
Belpaire's avatar
Belpaire committed
19
20
21
22
23
24
25
26
        [ "namespace"
        , "sort"
        , "lhs"
        , "syn"
        , "inh"
        , "c"
        , "rewrite"
        , "import"
27
        , "NativeCode"
Belpaire's avatar
Belpaire committed
28
        ]
marton bognar's avatar
marton bognar committed
29
    , reservedOpNames = ["@", "=", ",", ".", ";", ":", "|"]
Belpaire's avatar
Belpaire committed
30
31
    }

marton bognar's avatar
marton bognar committed
32
inboundTokenParser :: TokenParser st
marton bognar's avatar
marton bognar committed
33
inboundTokenParser = makeTokenParser myDef
marton bognar's avatar
marton bognar committed
34
35

pIdentifier :: Parser String
36
pIdentifier = identifier inboundTokenParser
marton bognar's avatar
marton bognar committed
37
38

pBrackets :: Parser a -> Parser a
39
pBrackets = brackets inboundTokenParser
marton bognar's avatar
marton bognar committed
40
41

pReserved :: String -> Parser ()
42
pReserved = reserved inboundTokenParser
marton bognar's avatar
marton bognar committed
43
44

pParens :: Parser a -> Parser a
45
pParens = parens inboundTokenParser
marton bognar's avatar
marton bognar committed
46
47

pBraces :: Parser a -> Parser a
48
pBraces = braces inboundTokenParser
marton bognar's avatar
marton bognar committed
49
50

pWhiteSpace :: Parser ()
51
pWhiteSpace = whiteSpace inboundTokenParser
Belpaire's avatar
Belpaire committed
52

marton bognar's avatar
marton bognar committed
53
54
55
pReservedOp :: String -> Parser ()
pReservedOp = reservedOp inboundTokenParser

marton bognar's avatar
marton bognar committed
56
57
58
59
60
pLanguage :: Parser Language
pLanguage = do
  pWhiteSpace
  idecls <- many pImports
  ndecls <- many pNameSpaceDecl
marton bognar's avatar
marton bognar committed
61
62
  sdecls <- many pSortDecl
  hsCode <- pHaskellCode
marton bognar's avatar
marton bognar committed
63
  return (ndecls, sdecls, idecls, hsCode)
Belpaire's avatar
Belpaire committed
64

marton bognar's avatar
marton bognar committed
65
66
-- * Imports
-- ----------------------------------------------------------------------------
Belpaire's avatar
Belpaire committed
67

marton bognar's avatar
marton bognar committed
68
-- | Parse one complete import line
marton bognar's avatar
marton bognar committed
69
pImports :: Parser (String, [String])
marton bognar's avatar
marton bognar committed
70
71
72
73
pImports = do
  pReserved "import"
  name <- pImportsName
  chooselist <- pImportChoose
marton bognar's avatar
marton bognar committed
74
  return (name, chooselist)
Belpaire's avatar
Belpaire committed
75

marton bognar's avatar
marton bognar committed
76
-- | Parse the module name (dot-separated strings)
marton bognar's avatar
marton bognar committed
77
78
79
80
81
pImportsName :: Parser String
pImportsName =
  pParens $ do
    list <- many pNameDot
    a <- pIdentifier
marton bognar's avatar
marton bognar committed
82
    return (intercalate "." (list ++ [a]))
Belpaire's avatar
Belpaire committed
83

marton bognar's avatar
marton bognar committed
84
-- | Parse one section of the module name
marton bognar's avatar
marton bognar committed
85
86
pNameDot :: Parser String
pNameDot =
marton bognar's avatar
marton bognar committed
87
  try
marton bognar's avatar
marton bognar committed
88
    (do a <- pIdentifier
marton bognar's avatar
marton bognar committed
89
        pReservedOp "."
marton bognar's avatar
marton bognar committed
90
        return a)
Belpaire's avatar
Belpaire committed
91

marton bognar's avatar
marton bognar committed
92
-- | Parse specifically selected entities from the module
marton bognar's avatar
marton bognar committed
93
pImportChoose :: Parser [String]
marton bognar's avatar
marton bognar committed
94
pImportChoose = try (pParens $ many pIdentifier) <|> return []
Belpaire's avatar
Belpaire committed
95

marton bognar's avatar
marton bognar committed
96
97
-- * Namespaces
-- ----------------------------------------------------------------------------
Belpaire's avatar
Belpaire committed
98

marton bognar's avatar
marton bognar committed
99
-- | Parse a namespace declaration
100
pNameSpaceDecl :: Parser NamespaceDef
marton bognar's avatar
marton bognar committed
101
pNameSpaceDecl =
marton bognar's avatar
marton bognar committed
102
  MkNameSpace <$ pReserved "namespace" <*> pNameSpaceName <* pReservedOp ":" <*>
103
  pSortName
Belpaire's avatar
Belpaire committed
104

marton bognar's avatar
marton bognar committed
105
-- | Parse a namespace's name
106
pNameSpaceName :: Parser NamespaceName
Belpaire's avatar
Belpaire committed
107
108
pNameSpaceName = pIdentifier

marton bognar's avatar
marton bognar committed
109
110
111
112
-- | Parse a sort's name
pSortName :: Parser SortName
pSortName = pIdentifier

marton bognar's avatar
marton bognar committed
113
114
115
-- * Sort declarations
-- ----------------------------------------------------------------------------

marton bognar's avatar
marton bognar committed
116
-- | Parse a sort declaration
marton bognar's avatar
marton bognar committed
117
pSortDecl :: Parser SortDef
marton bognar's avatar
marton bognar committed
118
pSortDecl = try pSortDeclRewrite <|> pSortDeclNoRewrite
marton bognar's avatar
marton bognar committed
119

marton bognar's avatar
marton bognar committed
120
-- | Parse a sort declaration with a rewrite rule
marton bognar's avatar
marton bognar committed
121
122
pSortDeclRewrite :: Parser SortDef
pSortDeclRewrite = do
marton bognar's avatar
marton bognar committed
123
  pReserved "sort"
marton bognar's avatar
marton bognar committed
124
  b <- pSortName
marton bognar's avatar
marton bognar committed
125
  pReserved "rewrite"
marton bognar's avatar
marton bognar committed
126
127
128
129
  c <- many pInstance
  d <- many pCtorDecl
  return (MkDefSort b c d True)

marton bognar's avatar
marton bognar committed
130
-- | Parse a sort declaration with no rewrite rule
marton bognar's avatar
marton bognar committed
131
132
pSortDeclNoRewrite :: Parser SortDef
pSortDeclNoRewrite = do
marton bognar's avatar
marton bognar committed
133
  pReserved "sort"
marton bognar's avatar
marton bognar committed
134
135
136
137
138
  b <- pSortName
  c <- many pInstance
  d <- many pCtorDecl
  return (MkDefSort b c d False)

marton bognar's avatar
marton bognar committed
139
-- | Parse a namespace instance
marton bognar's avatar
marton bognar committed
140
pInstance :: Parser Context
marton bognar's avatar
marton bognar committed
141
pInstance = pInh <|> pSyn
Belpaire's avatar
Belpaire committed
142

marton bognar's avatar
marton bognar committed
143
-- | Parse an inherited namespace instance
marton bognar's avatar
marton bognar committed
144
pInh :: Parser Context
marton bognar's avatar
marton bognar committed
145
146
pInh = do
  pReserved "inh"
marton bognar's avatar
marton bognar committed
147
148
  a <- pInstanceName
  b <- pNameSpaceName
marton bognar's avatar
marton bognar committed
149
  return (INH a b)
Belpaire's avatar
Belpaire committed
150

marton bognar's avatar
marton bognar committed
151
-- | Parse a synthesized namespace instance
marton bognar's avatar
marton bognar committed
152
pSyn :: Parser Context
marton bognar's avatar
marton bognar committed
153
154
pSyn = do
  pReserved "syn"
marton bognar's avatar
marton bognar committed
155
156
  a <- pInstanceName
  b <- pNameSpaceName
marton bognar's avatar
marton bognar committed
157
  return (SYN a b)
Belpaire's avatar
Belpaire committed
158

marton bognar's avatar
marton bognar committed
159
160
161
162
163
164
165
166
-- | Parse a namespace instance's name
pInstanceName :: Parser SortName
pInstanceName = pIdentifier

-- | Parse a constructor definition
pCtorDecl :: Parser ConstructorDef
pCtorDecl = do
  pReservedOp "|"
167
168
169
  try pVarCtor <|>
   try pBindCtor <|>
   pDefCtor
marton bognar's avatar
marton bognar committed
170

171
-- | Parse a constructor's name
marton bognar's avatar
marton bognar committed
172
173
pCtorName :: Parser ConstructorName
pCtorName = pIdentifier
Belpaire's avatar
Belpaire committed
174

175
176
177
178
-- | Parse a variable constructor
pVarCtor :: Parser ConstructorDef
pVarCtor = do
  name <- pCtorName
marton bognar's avatar
marton bognar committed
179
180
  a <- pVarNameSpace
  return (MkVarConstructor name a)
181
182
  where
    -- | Parse a namespace variable
183
    pVarNameSpace :: Parser NamespaceName
184
185
186
187
188
189
190
191
192
193
    pVarNameSpace =
      pParens $ do
        _ <- pIdentifier
        pReservedOp "@"
        pIdentifier

-- | Parse a binder constructor
pBindCtor :: Parser ConstructorDef
pBindCtor = do
  name <- pCtorName
194
195
196
197
198
199
200
  lists <- many (try pConstructorListsName)
  folds <- many (try pFolds)
  sorts <- many pConstructorSortName
  haskellTypes <- many pHaskellTypes
  namespace <- pConstructorNameSpaceName
  rules <- many pRule
  return (MkBindConstructor name lists sorts folds namespace rules haskellTypes)
201
202
203
204
205

-- | Parse a non-binder constructor
pDefCtor :: Parser ConstructorDef
pDefCtor = do
  name <- pCtorName
206
207
208
209
210
211
  lists <- many (try pConstructorListsName)
  folds <- many (try pFolds)
  sorts <- many pConstructorSortName
  haskellTypes <- many pHaskellTypes
  rules <- many pRule
  return (MkDefConstructor name lists sorts folds rules haskellTypes)
Belpaire's avatar
Belpaire committed
212

marton bognar's avatar
marton bognar committed
213
-- | Parse a constructor parameter with a list type
marton bognar's avatar
marton bognar committed
214
215
216
217
pConstructorListsName :: Parser (String, SortName)
pConstructorListsName =
  pParens $ do
    a <- pIdentifier
marton bognar's avatar
marton bognar committed
218
    pReservedOp ":"
marton bognar's avatar
marton bognar committed
219
220
    b <- pBracketSort
    return (a, b)
marton bognar's avatar
marton bognar committed
221
222
223
  where
    pBracketSort :: Parser SortName
    pBracketSort = pBrackets pIdentifier
Belpaire's avatar
Belpaire committed
224

marton bognar's avatar
marton bognar committed
225
-- | Parse a constructor parameter with a fold type (??)
marton bognar's avatar
marton bognar committed
226
227
228
pFolds :: Parser (String, SortName, FoldName)
pFolds =
  pParens $ do
marton bognar's avatar
marton bognar committed
229
    iden <- pIdentifier
marton bognar's avatar
marton bognar committed
230
    pReservedOp ":"
marton bognar's avatar
marton bognar committed
231
    foldname <- pIdentifier
marton bognar's avatar
marton bognar committed
232
233
    sortName <- pIdentifier
    return (iden, sortName, foldname)
Belpaire's avatar
Belpaire committed
234

marton bognar's avatar
marton bognar committed
235
-- | Parse a constructor parameter with a regular sort type
marton bognar's avatar
marton bognar committed
236
237
238
239
pConstructorSortName :: Parser (String, SortName)
pConstructorSortName =
  pParens $ do
    a <- pIdentifier
marton bognar's avatar
marton bognar committed
240
    pReservedOp ":"
marton bognar's avatar
marton bognar committed
241
242
    b <- pIdentifier
    return (a, b)
Belpaire's avatar
Belpaire committed
243

marton bognar's avatar
marton bognar committed
244
-- | Parse a constructor parameter with a built-in type
marton bognar's avatar
marton bognar committed
245
pHaskellTypes :: Parser HaskellTypeName
marton bognar's avatar
marton bognar committed
246
pHaskellTypes = pBraces pIdentifier
marton bognar's avatar
marton bognar committed
247

marton bognar's avatar
marton bognar committed
248
-- | Parse the binding parameter for a constructor
249
pConstructorNameSpaceName :: Parser (String, NamespaceName)
marton bognar's avatar
marton bognar committed
250
251
252
pConstructorNameSpaceName =
  pBrackets $ do
    a <- pIdentifier
marton bognar's avatar
marton bognar committed
253
    pReservedOp ":"
marton bognar's avatar
marton bognar committed
254
255
256
    b <- pIdentifier
    return (a, b)

marton bognar's avatar
marton bognar committed
257
-- | Parse namespace rules for a constructor
258
pRule :: Parser AttributeDef
marton bognar's avatar
marton bognar committed
259
260
pRule = do
  a <- pLeftExpr
marton bognar's avatar
marton bognar committed
261
  pReservedOp "="
marton bognar's avatar
marton bognar committed
262
263
264
  b <- pRightExpr
  return (a, b)

265
-- | Parse the left side of a namespace rule
marton bognar's avatar
marton bognar committed
266
267
pLeftExpr :: Parser LeftExpr
pLeftExpr = pLHSLeftExpr <|> pSubLeftExpr
268
269
270
271
272
273
274
275
276
277
  where
    pLHSLeftExpr :: Parser LeftExpr
    pLHSLeftExpr = do
      a <- pLHSExpr
      return (LeftLHS a)

    pSubLeftExpr :: Parser LeftExpr
    pSubLeftExpr = do
      (a, b) <- pSubExpr
      return (LeftSub a b)
marton bognar's avatar
marton bognar committed
278

279
-- | Parse the right side of a namespace rule
marton bognar's avatar
marton bognar committed
280
pRightExpr :: Parser RightExpr
marton bognar's avatar
marton bognar committed
281
pRightExpr = try pRightExprAdd <|> pRightExprLHS <|> pRightExprSub
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
  where
    pRightExprAdd :: Parser RightExpr
    pRightExprAdd = do
      a <- pRightExprLHS <|> pRightExprSub
      pReservedOp ","
      b <- pIdentifier
      return (RightAdd a b)

    pRightExprLHS :: Parser RightExpr
    pRightExprLHS = do
      a <- pLHSExpr
      return (RightLHS a)

    pRightExprSub :: Parser RightExpr
    pRightExprSub = do
      (a, b) <- pSubExpr
      return (RightSub a b)

-- | Parse an lhs expression (??)
marton bognar's avatar
marton bognar committed
301
302
pLHSExpr :: Parser String
pLHSExpr = do
Belpaire's avatar
Belpaire committed
303
  pReserved "lhs"
marton bognar's avatar
marton bognar committed
304
  pReservedOp "."
marton bognar's avatar
marton bognar committed
305
306
  pIdentifier

307
-- | Parse a subexpression (??)
marton bognar's avatar
marton bognar committed
308
309
pSubExpr :: Parser (String, String)
pSubExpr = do
Belpaire's avatar
Belpaire committed
310
  a <- pIdentifier
marton bognar's avatar
marton bognar committed
311
312
313
314
  pReservedOp "."
  b <- pIdentifier
  return (a, b)

315
-- * Native code
marton bognar's avatar
marton bognar committed
316
-- ----------------------------------------------------------------------------
Belpaire's avatar
Belpaire committed
317

marton bognar's avatar
marton bognar committed
318
319
320
-- | Parse native code if not at the end of file
pHaskellCode :: Parser [String]
pHaskellCode = parseEOF <|> do
321
  pReserved "NativeCode"
marton bognar's avatar
marton bognar committed
322
  pHsCode
Belpaire's avatar
Belpaire committed
323

marton bognar's avatar
marton bognar committed
324
-- | Parse lines until the end of the file
Belpaire's avatar
Belpaire committed
325
326
327
328
329
pHsCode :: Parser [String]
pHsCode = do
  x <- line
  xs <-
    many $ do
marton bognar's avatar
marton bognar committed
330
      _ <- newline
Belpaire's avatar
Belpaire committed
331
      line
marton bognar's avatar
marton bognar committed
332
  eof
Belpaire's avatar
Belpaire committed
333
334
  return (x : xs)

marton bognar's avatar
marton bognar committed
335
-- | Return an empty array if at the end of the file
Belpaire's avatar
Belpaire committed
336
337
parseEOF :: Parser [String]
parseEOF = do
marton bognar's avatar
marton bognar committed
338
  eof
Belpaire's avatar
Belpaire committed
339
340
  return []

marton bognar's avatar
marton bognar committed
341
-- | Parse a line
marton bognar's avatar
marton bognar committed
342
line :: Parser String
marton bognar's avatar
marton bognar committed
343
line = many $ noneOf "\n"