1 {-# OPTIONS -Wall -Werror -fno-warn-missing-signatures #-}
3 module ParsecParser where
10 import Text.ParserCombinators.Parsec
11 --import Text.ParserCombinators.Parsec.Expr
12 import qualified Text.ParserCombinators.Parsec.Token as P
13 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 (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 p = do
96 maybeMname <- coreMaybeMname
98 return (maybeMname, theId)
100 coreMaybeMname = optionMaybe coreMname
102 coreRequiredQualifiedName = do
105 return (Just mname, theId)
108 -- Notice the '^' goes here:
109 -- it's part of a variable *occurrence*, not a module name.
111 nm <- try coreModuleName
115 coreAxiom :: Parser Axiom
116 coreAxiom = parens (do
117 coercionName <- coreQualifiedCon
123 coercionK <- try equalityKind <|> parens equalityKind
124 return (coercionName, tbs, coercionK))
126 coreTbinds :: Parser [Tbind]
127 coreTbinds = many coreTbind
129 coreTbindsGen :: CharParser () String -> Parser [Tbind]
130 -- The "try" here is important. Otherwise, when parsing:
131 -- "Node (^base:DataziTuple.Z3T)" (a cdef), we commit to
132 -- parsing (^base...) as a tbind rather than a type.
133 coreTbindsGen separator = many (try $ coreTbindGen separator)
135 coreTbind :: Parser Tbind
136 coreTbind = coreTbindGen whiteSpace
138 coreTbindGen :: CharParser () a -> Parser Tbind
139 coreTbindGen sep = (parens (do
142 kind <- symbol "::" >> coreKind
143 return (tyVar, kind))) <|>
144 (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
146 coreCdefs :: Parser [Cdef]
147 coreCdefs = sepBy1 coreCdef (symbol ";")
149 coreCdef :: Parser Cdef
151 dataConName <- coreQualifiedCon
152 whiteSpace -- important!
153 tBinds <- try $ coreTbindsGen (symbol "@")
154 -- This should be equivalent to (many coreAty)
155 -- But it isn't. WHY??
156 tys <- sepBy coreAtySaturated whiteSpace
157 return $ Constr dataConName tBinds tys
159 coreTRep :: Parser (Maybe Ty)
160 -- note that the "=" is inside here since if there's
161 -- no rhs for the newtype, there's no "="
162 coreTRep = optionMaybe (do
166 coreType :: Parser Ty
167 coreType = coreForallTy <|> (do
169 -- whiteSpace is important!
171 -- This says: If there is at least one ("-> ty"..) thing,
172 -- use it. If not, don't consume any input.
173 maybeRest <- option [] (many1 (symbol "->" >> coreType))
174 return $ case maybeRest of
176 stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
181 -- The "try" is necessary:
182 -- otherwise, parsing "T " fails rather
183 -- than returning "T".
184 maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
186 -- so I'm not sure I like this... it's basically doing
187 -- typechecking (kind-checking?) in the parser.
188 -- However, the type syntax as defined in Core.hs sort of
190 ATy t -> foldl Tapp t maybeRest
191 Trans k -> app k 2 maybeRest "trans"
192 Sym k -> app k 1 maybeRest "sym"
193 Unsafe k -> app k 2 maybeRest "unsafe"
194 LeftCo k -> app k 1 maybeRest "left"
195 RightCo k -> app k 1 maybeRest "right")
196 where app k arity args _ | length args == arity = k args
198 primCoercionError (err ++
199 ("Args were: " ++ show args))
201 coreAtySaturated :: Parser Ty
202 coreAtySaturated = do
206 _ -> unexpected "coercion ty"
208 coreAty :: Parser ATyOp
209 coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
211 coreTvar :: Parser Ty
212 coreTvar = try identifier >>= (return . Tvar)
214 coreTcon :: Parser ATyOp
215 -- TODO: Change the grammar
216 -- A Tcon can be an uppercase type constructor
217 -- or a lowercase (always qualified) coercion variable
219 -- Special case is first so that (CoUnsafe .. ..) gets parsed as
220 -- a prim. coercion app and not a Tcon app.
221 -- But the whole thing is so bogus.
223 -- the "try"s are crucial; they force
225 maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
227 return $ case maybeCoercion of
228 TransC -> Trans (\ [x,y] -> TransCoercion x y)
229 SymC -> Sym (\ [x] -> SymCoercion x)
230 UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
231 LeftC -> LeftCo (\ [x] -> LeftCoercion x)
232 RightC -> RightCo (\ [x] -> RightCoercion x))
233 <|> (coreQualifiedCon >>= (return . ATy . Tcon))
235 data CoercionTy = TransC | SymC | UnsafeC | LeftC | RightC
237 symCo, transCo, unsafeCo :: Parser CoercionTy
238 -- Would be better not to wire these in quite this way. Sigh
239 symCo = string "^ghczmprim:GHCziPrim.sym" >> return SymC
240 transCo = string "^ghczmprim:GHCziPrim.trans" >> return TransC
241 unsafeCo = string "^ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC
242 leftCo = string "^ghczmprim:GHCziPrim.left" >> return LeftC
243 rightCo = string "^ghczmprim:GHCziPrim.right" >> return RightC
245 coreFunTy :: Parser Ty
252 return $ tArrow argTy resTy
254 coreForallTy :: Parser Ty
257 tBinds <- many1 coreTbind
260 return $ foldr Tforall bodyTy tBinds
262 -- TODO: similar to coreType. should refactor
263 coreKind :: Parser Kind
266 maybeRest <- option [] (many1 (symbol "->" >> coreKind))
267 return $ foldl Karrow hd maybeRest
269 coreAtomicKind = try liftedKind <|> try unliftedKind
270 <|> try openKind {- <|> try (parens equalityKind) -}
271 <|> try (parens coreKind)
291 -- Only used internally within the parser:
292 -- represents either a Tcon, or a continuation
293 -- for a primitive coercion
298 | Unsafe ([Ty] -> Ty)
299 | LeftCo ([Ty] -> Ty)
300 | RightCo ([Ty] -> Ty)
302 coreVdefGroups :: Parser [Vdefg]
303 coreVdefGroups = option [] (do
304 theFirstVdef <- coreVdefg
306 others <- coreVdefGroups
307 return $ theFirstVdef:others)
309 coreVdefg :: Parser Vdefg
310 coreVdefg = coreRecVdef <|> coreNonrecVdef
314 braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
316 coreNonrecVdef = coreVdef >>= (return . Nonrec)
319 (vdefLhs, vdefTy) <- topVbind
323 vdefRhs <- coreFullExp
324 return $ Vdef (vdefLhs, vdefTy, vdefRhs)
326 coreAtomicExp :: Parser Exp
328 -- For stupid reasons, the whiteSpace is necessary.
329 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
331 res <- choice [ try coreVar,
338 coreFullExp = (choice [coreLam, coreLet,
339 coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
340 -- The "try" is necessary so that we backtrack
341 -- when we see a var (that is not an app)
346 -- it's important to have a separate coreAtomicExp (that any app exp
347 -- begins with) and to define the args in terms of many1.
348 -- previously, coreAppExp could parse either an atomic exp (an app with
349 -- 0 arguments) or an app with >= 1 arguments, but that led to ambiguity.
350 oper <- try coreAtomicExp
352 args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
353 -- note this MUST be coreAty, not coreType, because otherwise:
354 -- "A @ B c" gets parsed as "A @ (B c)"
355 ((symbol "@" >> coreAtySaturated) >>= (return . Right))))
356 return $ foldl (\ op ->
357 either (App op) (Appt op)) oper args
359 coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual)))
361 coreDcon = coreQualifiedCon >>= (return . Dcon)
363 coreLit :: Parser Exp
364 coreLit = parens (coreLiteral >>= (return . Lit))
366 coreLiteral :: Parser Lit
375 binds <- coreLambdaBinds
378 return $ foldr Lam body binds
385 return $ Let vdefg body
388 ty <- coreAtySaturated
389 scrut <- coreAtomicExp
391 vBind <- parens lambdaBind
393 return $ Case scrut vBind ty alts
397 -- The parens are CRUCIAL, o/w it's ambiguous
398 body <- try (parens coreFullExp)
400 ty <- try coreAtySaturated
401 return $ Cast body ty
409 -- TODO: This isn't in the grammar, but GHC
410 -- always prints "external ccall". investigate...
413 t <- coreAtySaturated
414 return $ External s t) <|>
415 -- TODO: I don't really understand what this does
417 reserved "dynexternal"
419 t <- coreAtySaturated
420 return $ External "[dynamic]" t)
422 -- TODO: Totally punting this, but it needs to go in the grammar
426 return $ External s tAddrzh
428 coreLambdaBinds = many1 coreBind
430 coreBind = coreTbinding <|> coreVbind
432 coreTbinding = try coreAtTbind >>= (return . Tb)
433 coreVbind = parens (lambdaBind >>= (return . Vb))
435 coreAtTbind = (symbol "@") >> coreTbind
437 topVbind = aCoreVbind coreQualifiedName
438 lambdaBind = aCoreVbind identifier
447 aLit :: Parser CoreLit
448 aLit = intOrRatLit <|> charLit <|> stringLit
450 intOrRatLit :: Parser CoreLit
452 -- Int and lit combined into one to avoid ambiguity.
455 maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
457 Nothing -> return $ Lint lhs
458 Just rhs -> return $ Lrational (lhs % rhs)
460 anIntLit :: Parser Integer
462 sign <- option 1 (symbol "-" >> return (-1))
466 charLit :: Parser CoreLit
467 charLit = charLiteral >>= (return . Lchar)
468 -- make sure this is right
470 stringLit :: Parser CoreLit
471 stringLit = stringLiteral >>= (return . Lstring)
472 -- make sure this is right
474 coreAlts :: Parser [Alt]
475 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
477 coreAlt :: Parser Alt
478 coreAlt = conAlt <|> litAlt <|> defaultAlt
482 conName <- coreQualifiedCon
483 tBinds <- many (parens coreAtTbind)
484 whiteSpace -- necessary b/c otherwise we parse the next list as empty
485 vBinds <- many (parens lambdaBind)
488 rhs <- try coreFullExp
489 return $ Acon conName tBinds vBinds rhs
493 l <- parens coreLiteral
498 defaultAlt :: Parser Alt
503 return $ Adefault rhs
505 extCore = P.makeTokenParser extCoreDef
507 parens = P.parens extCore
508 braces = P.braces extCore
509 semiSep1 = P.semiSep1 extCore
510 -- newlines are allowed anywhere
511 whiteSpace = P.whiteSpace extCore <|> (newline >> return ())
512 symbol = P.symbol extCore
513 identifier = P.identifier extCore
514 -- Keywords all begin with '%'
515 reserved s = P.reserved extCore ('%':s)
516 natural = P.natural extCore
517 charLiteral = P.charLiteral extCore
518 stringLiteral = P.stringLiteral extCore
520 -- dodgy since Core doesn't really allow comments,
521 -- but we'll pretend...
522 extCoreDef = LanguageDef {
526 , nestedComments = True
528 , identLetter = lower <|> upper <|> digit <|> (char '\'')
529 , opStart = opLetter extCoreDef
530 , opLetter = oneOf ";=@:\\%_.*#?%"
531 , reservedNames = map ('%' :)
532 ["module", "data", "newtype", "rec",
533 "let", "in", "case", "of", "cast",
534 "note", "external", "forall"]
535 , reservedOpNames = [";", "=", "@", "::", "\\", "%_",
537 , caseSensitive = True
540 -- Stuff to help with testing in ghci.
541 pTest (Left a) = error (show a)
542 pTest (Right t) = print t
544 pTest1 :: Show a => CharParser () a -> String -> IO ()
546 let res = parse pr "" s
549 pt :: Show a => CharParser () a -> String -> IO ()