1 module ParsecParser where
6 import Text.ParserCombinators.Parsec
7 import Text.ParserCombinators.Parsec.Expr
8 import qualified Text.ParserCombinators.Parsec.Token as P
9 import Text.ParserCombinators.Parsec.Language
12 parseCore :: FilePath -> IO (Either ParseError Module)
13 parseCore = parseFromFile coreModule
15 coreModule :: Parser Module
19 mName <- coreModuleName
21 tdefs <- option [] coreTdefs
22 vdefGroups <- coreVdefGroups
24 return $ Module mName tdefs vdefGroups
26 coreModuleName :: Parser AnMname
28 pkgName <- corePackageName
30 (modHierarchy,baseName) <- coreHierModuleNames
31 return (pkgName, modHierarchy, baseName)
33 corePackageName :: Parser Pname
34 corePackageName = identifier
36 coreHierModuleNames :: Parser ([Id], Id)
37 coreHierModuleNames = do
38 parentName <- upperName
39 return $ splitModuleName parentName
41 upperName :: Parser Id
44 rest <- many (identLetter extCoreDef)
45 return $ firstChar:rest
47 coreTdefs :: Parser [Tdef]
48 coreTdefs = many coreTdef
50 coreTdef :: Parser Tdef
51 coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
54 withSemi p = try p `withTerminator` ";"
56 withTerminator p term = do
61 coreDataDecl :: Parser Tdef
64 tyCon <- coreQualifiedCon
65 whiteSpace -- important
70 cDefs <- braces coreCdefs
71 return $ Data tyCon tBinds cDefs
73 coreNewtypeDecl :: Parser Tdef
76 tyCon <- coreQualifiedCon
82 return $ Newtype tyCon tBinds axiom tyRep
84 coreQualifiedCon :: Parser (Mname, Id)
85 coreQualifiedCon = coreQualifiedGen upperName
87 coreQualifiedName = coreQualifiedGen identifier
89 coreQualifiedGen p = do
90 maybeMname <- coreMaybeMname
92 return (maybeMname, theId)
94 coreMaybeMname = optionMaybe coreMname
96 coreRequiredQualifiedName = do
99 return (Just mname, theId)
102 -- Notice the '^' goes here:
103 -- it's part of a variable *occurrence*, not a module name.
105 nm <- try coreModuleName
109 coreAxiom :: Parser Axiom
110 coreAxiom = parens (do
111 coercionName <- coreQualifiedCon
115 coercionKind <- coreKind
116 return (coercionName, coercionKind))
118 coreTbinds :: Parser [Tbind]
119 coreTbinds = many coreTbind
121 coreTbindsGen :: CharParser () String -> Parser [Tbind]
122 -- The "try" here is important. Otherwise, when parsing:
123 -- "Node (^base:DataziTuple.Z3T)" (a cdef), we commit to
124 -- parsing (^base...) as a tbind rather than a type.
125 coreTbindsGen separator = many (try $ coreTbindGen separator)
127 coreTbind :: Parser Tbind
128 coreTbind = coreTbindGen whiteSpace
130 coreTbindGen :: CharParser () a -> Parser Tbind
131 coreTbindGen sep = (parens (do
134 kind <- symbol "::" >> coreKind
135 return (tyVar, kind))) <|>
136 (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
138 coreCdefs :: Parser [Cdef]
139 coreCdefs = sepBy1 coreCdef (symbol ";")
141 coreCdef :: Parser Cdef
143 dataConName <- coreQualifiedCon
144 whiteSpace -- important!
145 tBinds <- try $ coreTbindsGen (symbol "@")
146 -- This should be equivalent to (many coreAty)
147 -- But it isn't. WHY??
148 tys <- sepBy coreAty whiteSpace
149 return $ Constr dataConName tBinds tys
151 coreTRep :: Parser (Maybe Ty)
152 -- note that the "=" is inside here since if there's
153 -- no rhs for the newtype, there's no "="
154 coreTRep = optionMaybe (do
158 coreType :: Parser Ty
159 coreType = coreForallTy <|> (do
161 -- whiteSpace is important!
163 -- This says: If there is at least one ("-> ty"..) thing,
164 -- use it. If not, don't consume any input.
165 maybeRest <- option [] (many1 (symbol "->" >> coreType))
166 return $ case maybeRest of
168 stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
171 coreBty = arrowThing coreAty coreAty whiteSpace Tapp
173 arrowThing :: Parser a -> Parser a -> Parser b -> (a -> a -> a) -> Parser a
174 arrowThing hdThing restThing sep op = do
176 -- The "try" is necessary:
177 -- otherwise, parsing "T " fails rather
178 -- than returning "T".
179 maybeRest <- option [] (many1 (try (sep >> restThing)))
180 return $ case maybeRest of
182 stuff -> foldl op hd maybeRest
184 coreAppTy :: Parser Ty
189 return $ Tapp bTy aTy
191 coreAty = try coreTcon <|> try coreTvar <|> parens coreType
193 coreTvar :: Parser Ty
194 coreTvar = try identifier >>= (return . Tvar)
196 coreTcon :: Parser Ty
197 -- TODO: Change the grammar
198 -- A Tcon can be an uppercase type constructor
199 -- or a lowercase (always qualified) coercion variable
200 coreTcon = (try coreQualifiedCon <|> coreRequiredQualifiedName)
203 coreTyApp :: Parser Ty
207 return $ Tapp operTy randTy
209 coreFunTy :: Parser Ty
216 return $ tArrow argTy resTy
218 coreForallTy :: Parser Ty
221 tBinds <- many1 coreTbind
224 return $ foldr Tforall bodyTy tBinds
226 -- TODO: similar to coreType. should refactor
227 coreKind :: Parser Kind
230 maybeRest <- option [] (many1 (symbol "->" >> coreKind))
231 return $ case maybeRest of
233 stuff -> foldl Karrow hd maybeRest
235 coreAtomicKind = try liftedKind <|> try unliftedKind
236 <|> try openKind <|> try (parens equalityKind)
237 <|> try (parens coreKind)
256 coreVdefGroups :: Parser [Vdefg]
257 coreVdefGroups = option [] (do
258 theFirstVdef <- coreVdefg
260 others <- coreVdefGroups
261 return $ theFirstVdef:others)
263 coreVdefg :: Parser Vdefg
264 coreVdefg = coreRecVdef <|> coreNonrecVdef
268 braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
270 coreNonrecVdef = coreVdef >>= (return . Nonrec)
273 (vdefLhs, vdefTy) <- topVbind
277 vdefRhs <- coreFullExp
278 return $ Vdef (vdefLhs, vdefTy, vdefRhs)
280 coreAtomicExp :: Parser Exp
282 -- For stupid reasons, the whiteSpace is necessary.
283 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
285 res <- choice [ try coreVar,
292 coreFullExp = (choice [coreLam, coreLet,
293 coreCase, coreCast, coreNote, coreExternal]) <|> (try coreAppExp)
294 -- The "try" is necessary so that we backtrack
295 -- when we see a var (that is not an app)
300 -- it's important to have a separate coreAtomicExp (that any app exp
301 -- begins with) and to define the args in terms of many1.
302 -- previously, coreAppExp could parse either an atomic exp (an app with
303 -- 0 arguments) or an app with >= 1 arguments, but that led to ambiguity.
304 oper <- try coreAtomicExp
306 args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
307 -- note this MUST be coreAty, not coreType, because otherwise:
308 -- "A @ B c" gets parsed as "A @ (B c)"
309 ((symbol "@" >> coreAty) >>= (return . Right))))
310 return $ foldl (\ op ->
311 either (App op) (Appt op)) oper args
313 coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual)))
315 coreDcon = coreQualifiedCon >>= (return . Dcon)
317 coreLit :: Parser Exp
318 coreLit = parens (coreLiteral >>= (return . Lit))
320 coreLiteral :: Parser Lit
329 binds <- coreLambdaBinds
332 return $ foldr Lam body binds
339 return $ Let vdefg body
343 scrut <- coreAtomicExp
345 vBind <- parens lambdaBind
347 return $ Case scrut vBind ty alts
351 -- The parens are CRUCIAL, o/w it's ambiguous
352 body <- try (parens coreFullExp)
355 return $ Cast body ty
363 -- TODO: This isn't in the grammar, but GHC
364 -- always prints "external ccall". investigate...
368 return $ External s t
370 coreLambdaBinds = many1 coreBind
372 coreBind = coreTbinding <|> coreVbind
374 coreTbinding = try coreAtTbind >>= (return . Tb)
375 coreVbind = parens (lambdaBind >>= (return . Vb))
377 coreAtTbind = (symbol "@") >> coreTbind
379 topVbind = aCoreVbind coreQualifiedName
380 lambdaBind = aCoreVbind identifier
389 aLit :: Parser CoreLit
390 aLit = intOrRatLit <|> charLit <|> stringLit
392 intOrRatLit :: Parser CoreLit
394 -- Int and lit combined into one to avoid ambiguity.
397 maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
399 Nothing -> return $ Lint lhs
400 Just rhs -> return $ Lrational (lhs % rhs)
402 anIntLit :: Parser Integer
404 sign <- option 1 (symbol "-" >> return (-1))
408 charLit :: Parser CoreLit
409 charLit = charLiteral >>= (return . Lchar)
410 -- make sure this is right
412 stringLit :: Parser CoreLit
413 stringLit = stringLiteral >>= (return . Lstring)
414 -- make sure this is right
416 coreAlts :: Parser [Alt]
417 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
419 coreAlt :: Parser Alt
420 coreAlt = conAlt <|> litAlt <|> defaultAlt
424 conName <- coreQualifiedCon
425 tBinds <- many (parens coreAtTbind)
426 whiteSpace -- necessary b/c otherwise we parse the next list as empty
427 vBinds <- many (parens lambdaBind)
430 rhs <- try coreFullExp
431 return $ Acon conName tBinds vBinds rhs
435 l <- parens coreLiteral
440 defaultAlt :: Parser Alt
445 return $ Adefault rhs
447 extCore = P.makeTokenParser extCoreDef
449 parens = P.parens extCore
450 braces = P.braces extCore
451 semiSep1 = P.semiSep1 extCore
452 -- newlines are allowed anywhere
453 whiteSpace = P.whiteSpace extCore <|> (newline >> return ())
454 symbol = P.symbol extCore
455 identifier = P.identifier extCore
456 -- Keywords all begin with '%'
457 reserved s = P.reserved extCore ('%':s)
458 natural = P.natural extCore
459 charLiteral = P.charLiteral extCore
460 stringLiteral = P.stringLiteral extCore
462 -- dodgy since Core doesn't really allow comments,
463 -- but we'll pretend...
464 extCoreDef = LanguageDef {
468 , nestedComments = True
470 , identLetter = lower <|> upper <|> digit <|> (char '\'')
471 , opStart = opLetter extCoreDef
472 , opLetter = oneOf ";=@:\\%_.*#?%"
473 , reservedNames = map ('%' :)
474 ["module", "data", "newtype", "rec",
475 "let", "in", "case", "of", "cast",
476 "note", "external", "forall"]
477 , reservedOpNames = [";", "=", "@", "::", "\\", "%_",
479 , caseSensitive = True
482 -- Stuff to help with testing in ghci.
483 pTest (Left a) = error (show a)
484 pTest (Right t) = print t
486 pTest1 :: Show a => CharParser () a -> String -> IO ()
488 let res = parse pr "" s
491 pt :: Show a => CharParser () a -> String -> IO ()