1 {-# OPTIONS -Wall -fno-warn-missing-signatures #-}
3 module Language.Core.ParsecParser (parseCore, coreModuleName, coreTcon,
4 coreQualifiedGen, upperName, identifier, coreType, coreKind,
5 coreTbinds, parens, braces, topVbind) where
7 import Language.Core.Core
8 import Language.Core.Check
9 import Language.Core.Encoding
10 import Language.Core.PrimCoercions
12 import Text.ParserCombinators.Parsec
13 import qualified Text.ParserCombinators.Parsec.Token as P
14 import Text.ParserCombinators.Parsec.Language
19 parseCore :: FilePath -> IO (Either ParseError Module)
20 parseCore = parseFromFile coreModule
22 coreModule :: Parser Module
26 mName <- coreModuleName
28 tdefs <- option [] coreTdefs
29 vdefGroups <- coreVdefGroups
31 return $ Module mName tdefs vdefGroups
33 coreModuleName :: Parser AnMname
35 pkgName <- corePackageName
37 (modHierarchy,baseName) <- coreHierModuleNames
38 return $ M (pkgName, modHierarchy, baseName)
40 corePackageName :: Parser Pname
41 -- Package names can be lowercase or uppercase!
42 corePackageName = (identifier <|> upperName) >>= (return . P)
44 coreHierModuleNames :: Parser ([Id], Id)
45 coreHierModuleNames = do
46 parentName <- upperName
47 return $ splitModuleName parentName
49 upperName :: Parser Id
52 rest <- many (identLetter extCoreDef)
53 return $ firstChar:rest
55 coreTdefs :: Parser [Tdef]
56 coreTdefs = many coreTdef
58 coreTdef :: Parser Tdef
59 coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
62 withSemi p = try p `withTerminator` ";"
64 withTerminator p term = do
69 coreDataDecl :: Parser Tdef
72 tyCon <- coreQualifiedCon
73 whiteSpace -- important
78 cDefs <- braces coreCdefs
79 return $ Data tyCon tBinds cDefs
81 coreNewtypeDecl :: Parser Tdef
84 tyCon <- coreQualifiedCon
86 coercionName <- coreQualifiedCon
90 return $ Newtype tyCon coercionName tBinds tyRep
92 coreQualifiedCon :: Parser (Mname, Id)
93 coreQualifiedCon = coreQualifiedGen upperName
95 coreQualifiedName = coreQualifiedGen identifier
97 coreQualifiedGen :: Parser String -> Parser (Mname, Id)
98 coreQualifiedGen p = (try (do
99 packageIdOrVarName <- corePackageName
100 maybeRest <- optionMaybe (char ':' >> coreHierModuleNames)
102 -- unqualified id, so backtrack
104 -- qualified name, so look for the id part
105 Just (modHierarchy, baseName) -> do
109 (Just $ M (packageIdOrVarName, modHierarchy, baseName),
112 (p >>= (\ res -> return (Nothing, res)))
114 coreTbinds :: Parser [Tbind]
115 coreTbinds = many coreTbind
117 coreTbindsGen :: CharParser () String -> Parser [Tbind]
118 -- The "try" here is important. Otherwise, when parsing:
119 -- "Node (^base:DataziTuple.Z3T)" (a cdef), we commit to
120 -- parsing (^base...) as a tbind rather than a type.
121 coreTbindsGen separator = many (try $ coreTbindGen separator)
123 coreTbind :: Parser Tbind
124 coreTbind = coreTbindGen whiteSpace
126 coreTbindGen :: CharParser () a -> Parser Tbind
127 coreTbindGen sep = (parens (do
130 kind <- symbol "::" >> coreKind
131 return (tyVar, kind))) <|>
132 (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
134 coreCdefs :: Parser [Cdef]
135 coreCdefs = sepBy1 coreCdef (symbol ";")
137 coreCdef :: Parser Cdef
139 dataConName <- coreQualifiedCon
140 whiteSpace -- important!
141 tBinds <- try $ coreTbindsGen (symbol "@")
142 -- This should be equivalent to (many coreAty)
143 -- But it isn't. WHY??
144 tys <- sepBy coreAtySaturated whiteSpace
145 return $ Constr dataConName tBinds tys
147 coreTRep :: Parser Ty
148 -- note that the "=" is inside here since if there's
149 -- no rhs for the newtype, there's no "="
150 coreTRep = symbol "=" >> try coreType
152 coreType :: Parser Ty
153 coreType = coreForallTy <|> (do
155 -- whiteSpace is important!
157 -- This says: If there is at least one ("-> ty"..) thing,
158 -- use it. If not, don't consume any input.
159 maybeRest <- option [] (many1 (symbol "->" >> coreType))
160 return $ case maybeRest of
162 stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
167 -- The "try" is necessary:
168 -- otherwise, parsing "T " fails rather
169 -- than returning "T".
170 maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
172 -- so I'm not sure I like this... it's basically doing
173 -- typechecking (kind-checking?) in the parser.
174 -- However, the type syntax as defined in Core.hs sort of
176 ATy t -> foldl Tapp t maybeRest
177 Trans k -> app k 2 maybeRest "trans"
178 Sym k -> app k 1 maybeRest "sym"
179 Unsafe k -> app k 2 maybeRest "unsafe"
180 LeftCo k -> app k 1 maybeRest "left"
181 RightCo k -> app k 1 maybeRest "right"
182 InstCo k -> app k 2 maybeRest "inst")
183 where app k arity args _ | length args == arity = k args
185 primCoercionError (err ++
186 ("Args were: " ++ show args))
188 coreAtySaturated :: Parser Ty
189 coreAtySaturated = do
193 _ -> unexpected "coercion ty"
195 coreAty :: Parser ATyOp
196 coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
198 coreTvar :: Parser Ty
199 coreTvar = try identifier >>= (return . Tvar)
201 coreTcon :: Parser ATyOp
202 -- TODO: Change the grammar
203 -- A Tcon can be an uppercase type constructor
204 -- or a lowercase (always qualified) coercion variable
206 -- Special case is first so that (CoUnsafe .. ..) gets parsed as
207 -- a prim. coercion app and not a Tcon app.
208 -- But the whole thing is so bogus.
210 -- the "try"s are crucial; they force
212 maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
213 try instCo, try leftCo, rightCo]
214 return $ case maybeCoercion of
215 TransC -> Trans (\ [x,y] -> TransCoercion x y)
216 SymC -> Sym (\ [x] -> SymCoercion x)
217 UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
218 LeftC -> LeftCo (\ [x] -> LeftCoercion x)
219 RightC -> RightCo (\ [x] -> RightCoercion x)
220 InstC -> InstCo (\ [x,y] -> InstCoercion x y))
221 <|> (coreQualifiedCon >>= (return . ATy . Tcon))
223 data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC
225 symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: Parser CoercionTy
226 symCo = string "%sym" >> return SymC
227 transCo = string "%trans" >> return TransC
228 unsafeCo = string "%unsafe" >> return UnsafeC
229 leftCo = string "%left" >> return LeftC
230 rightCo = string "%right" >> return RightC
231 instCo = string "%inst" >> return InstC
233 coreForallTy :: Parser Ty
236 tBinds <- many1 coreTbind
239 return $ foldr Tforall bodyTy tBinds
241 -- TODO: similar to coreType. should refactor
242 coreKind :: Parser Kind
245 maybeRest <- option [] (many1 (symbol "->" >> coreKind))
246 return $ foldl Karrow hd maybeRest
248 coreAtomicKind = try liftedKind <|> try unliftedKind
249 <|> try openKind <|> try (do
250 (from,to) <- parens equalityKind
251 return $ Keq from to)
252 <|> try (parens coreKind)
272 -- Only used internally within the parser:
273 -- represents either a Tcon, or a continuation
274 -- for a primitive coercion
279 | Unsafe ([Ty] -> Ty)
280 | LeftCo ([Ty] -> Ty)
281 | RightCo ([Ty] -> Ty)
282 | InstCo ([Ty] -> Ty)
284 coreVdefGroups :: Parser [Vdefg]
285 coreVdefGroups = option [] (do
286 theFirstVdef <- coreVdefg
288 others <- coreVdefGroups
289 return $ theFirstVdef:others)
291 coreVdefg :: Parser Vdefg
292 coreVdefg = coreRecVdef <|> coreNonrecVdef
296 braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
298 coreNonrecVdef = coreVdef >>= (return . Nonrec)
301 (vdefLhs, vdefTy) <- try topVbind <|> (do
302 (v, ty) <- lambdaBind
303 return (unqual v, ty))
307 vdefRhs <- coreFullExp
308 return $ Vdef (vdefLhs, vdefTy, vdefRhs)
310 coreAtomicExp :: Parser Exp
312 -- For stupid reasons, the whiteSpace is necessary.
313 -- Without it, (pt coreAppExp "w a:B.C ") doesn't work.
315 res <- choice [try coreDconOrVar,
321 coreFullExp = (choice [coreLam, coreLet,
322 coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
323 -- The "try" is necessary so that we backtrack
324 -- when we see a var (that is not an app)
329 -- it's important to have a separate coreAtomicExp (that any app exp
330 -- begins with) and to define the args in terms of many1.
331 -- previously, coreAppExp could parse either an atomic exp (an app with
332 -- 0 arguments) or an app with >= 1 arguments, but that led to ambiguity.
333 oper <- try coreAtomicExp
335 args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
336 -- note this MUST be coreAty, not coreType, because otherwise:
337 -- "A @ B c" gets parsed as "A @ (B c)"
338 ((symbol "@" >> coreAtySaturated) >>= (return . Right))))
339 return $ foldl (\ op ->
340 either (App op) (Appt op)) oper args
343 theThing <- coreQualifiedGen (try upperName <|> identifier)
344 return $ case theThing of
345 -- note that data constructors must be qualified
346 (Just _, idItself) | isUpper (head idItself)
350 coreLit :: Parser Exp
351 coreLit = parens (coreLiteral >>= (return . Lit))
353 coreLiteral :: Parser Lit
362 binds <- coreLambdaBinds
365 return $ foldr Lam body binds
372 return $ Let vdefg body
375 ty <- coreAtySaturated
376 scrut <- coreAtomicExp
378 vBind <- parens lambdaBind
380 return $ Case scrut vBind ty alts
384 -- The parens are CRUCIAL, o/w it's ambiguous
385 body <- try (parens coreFullExp)
387 ty <- try coreAtySaturated
388 return $ Cast body ty
396 -- TODO: This isn't in the grammar, but GHC
397 -- always prints "external ccall". investigate...
400 t <- coreAtySaturated
401 return $ External s t) <|>
402 -- TODO: I don't really understand what this does
404 reserved "dynexternal"
406 t <- coreAtySaturated
407 return $ External "[dynamic]" t)
409 -- TODO: Totally punting this, but it needs to go in the grammar
413 return $ External s tAddrzh
415 coreLambdaBinds = many1 coreBind
417 coreBind = coreTbinding <|> coreVbind
419 coreTbinding = try coreAtTbind >>= (return . Tb)
420 coreVbind = parens (lambdaBind >>= (return . Vb))
422 coreAtTbind = (symbol "@") >> coreTbind
424 topVbind :: Parser (Qual Var, Ty)
425 topVbind = aCoreVbind coreQualifiedName
426 lambdaBind :: Parser (Var, Ty)
427 lambdaBind = aCoreVbind identifier
436 aLit :: Parser CoreLit
437 aLit = intOrRatLit <|> charLit <|> stringLit
439 intOrRatLit :: Parser CoreLit
441 -- Int and lit combined into one to avoid ambiguity.
444 maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
446 Nothing -> return $ Lint lhs
447 Just rhs -> return $ Lrational (lhs % rhs)
449 intLit :: Parser Integer
450 intLit = anIntLit <|> parens anIntLit
452 anIntLit :: Parser Integer
454 sign <- option 1 (symbol "-" >> return (-1))
458 charLit :: Parser CoreLit
459 charLit = charLiteral >>= (return . Lchar)
460 -- make sure this is right
462 stringLit :: Parser CoreLit
463 stringLit = stringLiteral >>= (return . Lstring)
464 -- make sure this is right
466 coreAlts :: Parser [Alt]
467 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
469 coreAlt :: Parser Alt
470 coreAlt = conAlt <|> litAlt <|> defaultAlt
474 conName <- coreQualifiedCon
475 tBinds <- many (parens coreAtTbind)
476 whiteSpace -- necessary b/c otherwise we parse the next list as empty
477 vBinds <- many (parens lambdaBind)
480 rhs <- try coreFullExp
481 return $ Acon conName tBinds vBinds rhs
485 l <- parens coreLiteral
490 defaultAlt :: Parser Alt
495 return $ Adefault rhs
499 let decoded = zDecodeString mn
501 -- We re-encode the individual parts so that:
502 -- main:Foo_Bar.Quux.baz
504 -- main:FoozuBarziQuux.baz
506 -- main:Foo_BarziQuux.baz
507 parts = map zEncodeString $ filter (notElem '.') $ groupBy
508 (\ c1 c2 -> c1 /= '.' && c2 /= '.')
510 (take (length parts - 1) parts, last parts)
512 extCore = P.makeTokenParser extCoreDef
514 parens = P.parens extCore
515 braces = P.braces extCore
516 -- newlines are allowed anywhere
517 whiteSpace = P.whiteSpace extCore <|> (newline >> return ())
518 symbol = P.symbol extCore
519 identifier = P.identifier extCore
520 -- Keywords all begin with '%'
521 reserved s = P.reserved extCore ('%':s)
522 natural = P.natural extCore
523 charLiteral = P.charLiteral extCore
524 stringLiteral = P.stringLiteral extCore
526 -- dodgy since Core doesn't really allow comments,
527 -- but we'll pretend...
528 extCoreDef = LanguageDef {
532 , nestedComments = True
534 , identLetter = lower <|> upper <|> digit <|> (char '\'')
535 , opStart = opLetter extCoreDef
536 , opLetter = oneOf ";=@:\\%_.*#?%"
537 , reservedNames = map ('%' :)
538 ["module", "data", "newtype", "rec",
539 "let", "in", "case", "of", "cast",
540 "note", "external", "forall"]
541 , reservedOpNames = [";", "=", "@", "::", "\\", "%_",
543 , caseSensitive = True
547 -- Stuff to help with testing in ghci.
548 pTest (Left a) = error (show a)
549 pTest (Right t) = print t
551 pTest1 :: Show a => CharParser () a -> String -> IO ()
553 let res = parse pr "" s
556 pt :: Show a => CharParser () a -> String -> IO ()