1 {-# OPTIONS -Wall -fno-warn-missing-signatures #-}
3 module ParsecParser (parseCore) where
10 import Text.ParserCombinators.Parsec
11 import qualified Text.ParserCombinators.Parsec.Token as P
12 import Text.ParserCombinators.Parsec.Language
16 parseCore :: FilePath -> IO (Either ParseError Module)
17 parseCore = parseFromFile coreModule
19 coreModule :: Parser Module
23 mName <- coreModuleName
25 tdefs <- option [] coreTdefs
26 vdefGroups <- coreVdefGroups
28 return $ Module mName tdefs vdefGroups
30 coreModuleName :: Parser AnMname
32 pkgName <- corePackageName
34 (modHierarchy,baseName) <- coreHierModuleNames
35 return $ M (pkgName, modHierarchy, baseName)
37 corePackageName :: Parser Pname
38 -- Package names can be lowercase or uppercase!
40 corePackageName = identifier <|> upperName
42 coreHierModuleNames :: Parser ([Id], Id)
43 coreHierModuleNames = do
44 parentName <- upperName
45 return $ splitModuleName parentName
47 upperName :: Parser Id
50 rest <- many (identLetter extCoreDef)
51 return $ firstChar:rest
53 coreTdefs :: Parser [Tdef]
54 coreTdefs = many coreTdef
56 coreTdef :: Parser Tdef
57 coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
60 withSemi p = try p `withTerminator` ";"
62 withTerminator p term = do
67 coreDataDecl :: Parser Tdef
70 tyCon <- coreQualifiedCon
71 whiteSpace -- important
76 cDefs <- braces coreCdefs
77 return $ Data tyCon tBinds cDefs
79 coreNewtypeDecl :: Parser Tdef
82 tyCon <- coreQualifiedCon
88 return $ Newtype tyCon tBinds axiom tyRep
90 coreQualifiedCon :: Parser (Mname, Id)
91 coreQualifiedCon = coreQualifiedGen upperName
93 coreQualifiedName = coreQualifiedGen identifier
95 coreQualifiedGen :: Parser String -> Parser (Mname, Id)
96 coreQualifiedGen p = (try (do
97 packageIdOrVarName <- corePackageName
98 maybeRest <- optionMaybe (char ':' >> coreHierModuleNames)
100 -- unqualified id, so backtrack
102 -- qualified name, so look for the id part
103 Just (modHierarchy, baseName) -> do
107 (Just $ M (packageIdOrVarName, modHierarchy, baseName),
110 (p >>= (\ res -> return (Nothing, res)))
112 coreAxiom :: Parser Axiom
113 coreAxiom = parens (do
114 coercionName <- coreQualifiedCon
120 coercionK <- try equalityKind <|> parens equalityKind
121 return (coercionName, tbs, coercionK))
123 coreTbinds :: Parser [Tbind]
124 coreTbinds = many coreTbind
126 coreTbindsGen :: CharParser () String -> Parser [Tbind]
127 -- The "try" here is important. Otherwise, when parsing:
128 -- "Node (^base:DataziTuple.Z3T)" (a cdef), we commit to
129 -- parsing (^base...) as a tbind rather than a type.
130 coreTbindsGen separator = many (try $ coreTbindGen separator)
132 coreTbind :: Parser Tbind
133 coreTbind = coreTbindGen whiteSpace
135 coreTbindGen :: CharParser () a -> Parser Tbind
136 coreTbindGen sep = (parens (do
139 kind <- symbol "::" >> coreKind
140 return (tyVar, kind))) <|>
141 (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
143 coreCdefs :: Parser [Cdef]
144 coreCdefs = sepBy1 coreCdef (symbol ";")
146 coreCdef :: Parser Cdef
148 dataConName <- coreQualifiedCon
149 whiteSpace -- important!
150 tBinds <- try $ coreTbindsGen (symbol "@")
151 -- This should be equivalent to (many coreAty)
152 -- But it isn't. WHY??
153 tys <- sepBy coreAtySaturated whiteSpace
154 return $ Constr dataConName tBinds tys
156 coreTRep :: Parser (Maybe Ty)
157 -- note that the "=" is inside here since if there's
158 -- no rhs for the newtype, there's no "="
159 coreTRep = optionMaybe (do
163 coreType :: Parser Ty
164 coreType = coreForallTy <|> (do
166 -- whiteSpace is important!
168 -- This says: If there is at least one ("-> ty"..) thing,
169 -- use it. If not, don't consume any input.
170 maybeRest <- option [] (many1 (symbol "->" >> coreType))
171 return $ case maybeRest of
173 stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
178 -- The "try" is necessary:
179 -- otherwise, parsing "T " fails rather
180 -- than returning "T".
181 maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
183 -- so I'm not sure I like this... it's basically doing
184 -- typechecking (kind-checking?) in the parser.
185 -- However, the type syntax as defined in Core.hs sort of
187 ATy t -> foldl Tapp t maybeRest
188 Trans k -> app k 2 maybeRest "trans"
189 Sym k -> app k 1 maybeRest "sym"
190 Unsafe k -> app k 2 maybeRest "unsafe"
191 LeftCo k -> app k 1 maybeRest "left"
192 RightCo k -> app k 1 maybeRest "right"
193 InstCo k -> app k 2 maybeRest "inst")
194 where app k arity args _ | length args == arity = k args
196 primCoercionError (err ++
197 ("Args were: " ++ show args))
199 coreAtySaturated :: Parser Ty
200 coreAtySaturated = do
204 _ -> unexpected "coercion ty"
206 coreAty :: Parser ATyOp
207 coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
209 coreTvar :: Parser Ty
210 coreTvar = try identifier >>= (return . Tvar)
212 coreTcon :: Parser ATyOp
213 -- TODO: Change the grammar
214 -- A Tcon can be an uppercase type constructor
215 -- or a lowercase (always qualified) coercion variable
217 -- Special case is first so that (CoUnsafe .. ..) gets parsed as
218 -- a prim. coercion app and not a Tcon app.
219 -- But the whole thing is so bogus.
221 -- the "try"s are crucial; they force
223 maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
224 try instCo, try leftCo, rightCo]
225 return $ case maybeCoercion of
226 TransC -> Trans (\ [x,y] -> TransCoercion x y)
227 SymC -> Sym (\ [x] -> SymCoercion x)
228 UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
229 LeftC -> LeftCo (\ [x] -> LeftCoercion x)
230 RightC -> RightCo (\ [x] -> RightCoercion x)
231 InstC -> InstCo (\ [x,y] -> InstCoercion x y))
232 <|> (coreQualifiedCon >>= (return . ATy . Tcon))
234 data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC
236 symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: Parser CoercionTy
237 -- Would be better not to wire these in quite this way. Sigh
238 symCo = string "ghczmprim:GHCziPrim.sym" >> return SymC
239 transCo = string "ghczmprim:GHCziPrim.trans" >> return TransC
240 unsafeCo = string "ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC
241 leftCo = string "ghczmprim:GHCziPrim.left" >> return LeftC
242 rightCo = string "ghczmprim:GHCziPrim.right" >> return RightC
243 instCo = string "ghczmprim:GHCziPrim.inst" >> return InstC
245 coreForallTy :: Parser Ty
248 tBinds <- many1 coreTbind
251 return $ foldr Tforall bodyTy tBinds
253 -- TODO: similar to coreType. should refactor
254 coreKind :: Parser Kind
257 maybeRest <- option [] (many1 (symbol "->" >> coreKind))
258 return $ foldl Karrow hd maybeRest
260 coreAtomicKind = try liftedKind <|> try unliftedKind
261 <|> try openKind <|> try (do
262 (from,to) <- parens equalityKind
263 return $ Keq from to)
264 <|> try (parens coreKind)
284 -- Only used internally within the parser:
285 -- represents either a Tcon, or a continuation
286 -- for a primitive coercion
291 | Unsafe ([Ty] -> Ty)
292 | LeftCo ([Ty] -> Ty)
293 | RightCo ([Ty] -> Ty)
294 | InstCo ([Ty] -> Ty)
296 coreVdefGroups :: Parser [Vdefg]
297 coreVdefGroups = option [] (do
298 theFirstVdef <- coreVdefg
300 others <- coreVdefGroups
301 return $ theFirstVdef:others)
303 coreVdefg :: Parser Vdefg
304 coreVdefg = coreRecVdef <|> coreNonrecVdef
308 braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
310 coreNonrecVdef = coreVdef >>= (return . Nonrec)
313 (vdefLhs, vdefTy) <- try topVbind <|> (do
314 (v, ty) <- lambdaBind
315 return (unqual v, ty))
319 vdefRhs <- coreFullExp
320 return $ Vdef (vdefLhs, vdefTy, vdefRhs)
322 coreAtomicExp :: Parser Exp
324 -- For stupid reasons, the whiteSpace is necessary.
325 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
327 res <- choice [try coreDconOrVar,
333 coreFullExp = (choice [coreLam, coreLet,
334 coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
335 -- The "try" is necessary so that we backtrack
336 -- when we see a var (that is not an app)
341 -- it's important to have a separate coreAtomicExp (that any app exp
342 -- begins with) and to define the args in terms of many1.
343 -- previously, coreAppExp could parse either an atomic exp (an app with
344 -- 0 arguments) or an app with >= 1 arguments, but that led to ambiguity.
345 oper <- try coreAtomicExp
347 args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
348 -- note this MUST be coreAty, not coreType, because otherwise:
349 -- "A @ B c" gets parsed as "A @ (B c)"
350 ((symbol "@" >> coreAtySaturated) >>= (return . Right))))
351 return $ foldl (\ op ->
352 either (App op) (Appt op)) oper args
355 theThing <- coreQualifiedGen (try upperName <|> identifier)
356 return $ case theThing of
357 -- note that data constructors must be qualified
358 (Just _, idItself) | isUpper (head idItself)
362 coreLit :: Parser Exp
363 coreLit = parens (coreLiteral >>= (return . Lit))
365 coreLiteral :: Parser Lit
374 binds <- coreLambdaBinds
377 return $ foldr Lam body binds
384 return $ Let vdefg body
387 ty <- coreAtySaturated
388 scrut <- coreAtomicExp
390 vBind <- parens lambdaBind
392 return $ Case scrut vBind ty alts
396 -- The parens are CRUCIAL, o/w it's ambiguous
397 body <- try (parens coreFullExp)
399 ty <- try coreAtySaturated
400 return $ Cast body ty
408 -- TODO: This isn't in the grammar, but GHC
409 -- always prints "external ccall". investigate...
412 t <- coreAtySaturated
413 return $ External s t) <|>
414 -- TODO: I don't really understand what this does
416 reserved "dynexternal"
418 t <- coreAtySaturated
419 return $ External "[dynamic]" t)
421 -- TODO: Totally punting this, but it needs to go in the grammar
425 return $ External s tAddrzh
427 coreLambdaBinds = many1 coreBind
429 coreBind = coreTbinding <|> coreVbind
431 coreTbinding = try coreAtTbind >>= (return . Tb)
432 coreVbind = parens (lambdaBind >>= (return . Vb))
434 coreAtTbind = (symbol "@") >> coreTbind
436 topVbind :: Parser (Qual Var, Ty)
437 topVbind = aCoreVbind coreQualifiedName
438 lambdaBind :: Parser (Var, Ty)
439 lambdaBind = aCoreVbind identifier
448 aLit :: Parser CoreLit
449 aLit = intOrRatLit <|> charLit <|> stringLit
451 intOrRatLit :: Parser CoreLit
453 -- Int and lit combined into one to avoid ambiguity.
456 maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
458 Nothing -> return $ Lint lhs
459 Just rhs -> return $ Lrational (lhs % rhs)
461 intLit :: Parser Integer
462 intLit = anIntLit <|> parens anIntLit
464 anIntLit :: Parser Integer
466 sign <- option 1 (symbol "-" >> return (-1))
470 charLit :: Parser CoreLit
471 charLit = charLiteral >>= (return . Lchar)
472 -- make sure this is right
474 stringLit :: Parser CoreLit
475 stringLit = stringLiteral >>= (return . Lstring)
476 -- make sure this is right
478 coreAlts :: Parser [Alt]
479 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
481 coreAlt :: Parser Alt
482 coreAlt = conAlt <|> litAlt <|> defaultAlt
486 conName <- coreQualifiedCon
487 tBinds <- many (parens coreAtTbind)
488 whiteSpace -- necessary b/c otherwise we parse the next list as empty
489 vBinds <- many (parens lambdaBind)
492 rhs <- try coreFullExp
493 return $ Acon conName tBinds vBinds rhs
497 l <- parens coreLiteral
502 defaultAlt :: Parser Alt
507 return $ Adefault rhs
509 extCore = P.makeTokenParser extCoreDef
511 parens = P.parens extCore
512 braces = P.braces extCore
513 -- newlines are allowed anywhere
514 whiteSpace = P.whiteSpace extCore <|> (newline >> return ())
515 symbol = P.symbol extCore
516 identifier = P.identifier extCore
517 -- Keywords all begin with '%'
518 reserved s = P.reserved extCore ('%':s)
519 natural = P.natural extCore
520 charLiteral = P.charLiteral extCore
521 stringLiteral = P.stringLiteral extCore
523 -- dodgy since Core doesn't really allow comments,
524 -- but we'll pretend...
525 extCoreDef = LanguageDef {
529 , nestedComments = True
531 , identLetter = lower <|> upper <|> digit <|> (char '\'')
532 , opStart = opLetter extCoreDef
533 , opLetter = oneOf ";=@:\\%_.*#?%"
534 , reservedNames = map ('%' :)
535 ["module", "data", "newtype", "rec",
536 "let", "in", "case", "of", "cast",
537 "note", "external", "forall"]
538 , reservedOpNames = [";", "=", "@", "::", "\\", "%_",
540 , caseSensitive = True
544 -- Stuff to help with testing in ghci.
545 pTest (Left a) = error (show a)
546 pTest (Right t) = print t
548 pTest1 :: Show a => CharParser () a -> String -> IO ()
550 let res = parse pr "" s
553 pt :: Show a => CharParser () a -> String -> IO ()