utils/ext-core/ParsecParser.hs

   1 module ParsecParser where
   2
   3 import Core
   4 import ParseGlue
   5
   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
  10 import Data.Ratio
  11
  12 parseCore :: FilePath -> IO (Either ParseError Module)
  13 parseCore = parseFromFile coreModule
  14
  15 coreModule :: Parser Module
  16 coreModule = do
  17    whiteSpace
  18    reserved "module"
  19    mName      <- coreModuleName
  20    whiteSpace
  21    tdefs      <- option [] coreTdefs
  22    vdefGroups <- coreVdefGroups
  23    eof
  24    return $ Module mName tdefs vdefGroups
  25
  26 coreModuleName :: Parser AnMname
  27 coreModuleName = do
  28    pkgName      <- corePackageName
  29    char ':'
  30    (modHierarchy,baseName) <- coreHierModuleNames
  31    return (pkgName, modHierarchy, baseName)
  32
  33 corePackageName :: Parser Pname
  34 corePackageName = identifier
  35
  36 coreHierModuleNames :: Parser ([Id], Id)
  37 coreHierModuleNames = do
  38    parentName <- upperName
  39    return $ splitModuleName parentName
  40
  41 upperName :: Parser Id
  42 upperName = do
  43    firstChar <- upper
  44    rest <- many (identLetter extCoreDef)
  45    return $ firstChar:rest
  46
  47 coreTdefs :: Parser [Tdef]
  48 coreTdefs = many coreTdef
  49
  50 coreTdef :: Parser Tdef
  51 coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
  52
  53
  54 withSemi p = try p `withTerminator` ";"
  55
  56 withTerminator p term = do
  57    x <- try p
  58    try $ symbol term
  59    return x
  60
  61 coreDataDecl :: Parser Tdef
  62 coreDataDecl = do
  63   reserved "data"
  64   tyCon  <- coreQualifiedCon
  65   whiteSpace -- important
  66   tBinds <- coreTbinds
  67   whiteSpace
  68   symbol "="
  69   whiteSpace
  70   cDefs  <- braces coreCdefs
  71   return $ Data tyCon tBinds cDefs
  72
  73 coreNewtypeDecl :: Parser Tdef
  74 coreNewtypeDecl = do
  75   reserved "newtype"
  76   tyCon  <- coreQualifiedCon
  77   whiteSpace
  78   tBinds <- coreTbinds
  79   symbol "^"
  80   axiom <- coreAxiom
  81   tyRep  <- try coreTRep
  82   return $ Newtype tyCon tBinds axiom tyRep
  83
  84 coreQualifiedCon :: Parser (Mname, Id)
  85 coreQualifiedCon = coreQualifiedGen upperName
  86
  87 coreQualifiedName = coreQualifiedGen identifier
  88
  89 coreQualifiedGen p = do
  90   maybeMname <- coreMaybeMname
  91   theId      <- p
  92   return (maybeMname, theId)
  93
  94 coreMaybeMname = optionMaybe coreMname
  95
  96 coreRequiredQualifiedName = do
  97   mname <- coreMname
  98   theId <- identifier
  99   return (Just mname, theId)
 100
 101 coreMname = do
 102 -- Notice the '^' goes here:
 103 -- it's part of a variable *occurrence*, not a module name.
 104   char '^'
 105   nm <- try coreModuleName
 106   symbol "."
 107   return nm
 108
 109 coreAxiom :: Parser Axiom
 110 coreAxiom = parens (do
 111               coercionName <- coreQualifiedCon
 112               whiteSpace
 113               symbol "::"
 114               whiteSpace
 115               coercionKind <- coreKind
 116               return (coercionName, coercionKind))
 117
 118 coreTbinds :: Parser [Tbind]
 119 coreTbinds = many coreTbind
 120
 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)
 126
 127 coreTbind :: Parser Tbind
 128 coreTbind = coreTbindGen whiteSpace
 129
 130 coreTbindGen :: CharParser () a -> Parser Tbind
 131 coreTbindGen sep = (parens (do
 132                      sep
 133                      tyVar <- identifier
 134                      kind <- symbol "::" >> coreKind
 135                      return (tyVar, kind))) <|>
 136                     (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
 137
 138 coreCdefs :: Parser [Cdef]
 139 coreCdefs = sepBy1 coreCdef (symbol ";")
 140
 141 coreCdef :: Parser Cdef
 142 coreCdef = do
 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
 150
 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
 155               symbol "="
 156               try coreType)
 157
 158 coreType :: Parser Ty
 159 coreType = coreForallTy <|> (do
 160              hd <- coreBty
 161              -- whiteSpace is important!
 162              whiteSpace
 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
 167                          [] -> hd
 168                          stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
 169
 170 coreBty :: Parser Ty
 171 coreBty = arrowThing coreAty coreAty whiteSpace Tapp
 172
 173 arrowThing :: Parser a -> Parser a -> Parser b -> (a -> a -> a) -> Parser a
 174 arrowThing hdThing restThing sep op = do
 175   hd <- hdThing
 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
 181              [] -> hd
 182              stuff -> foldl op hd maybeRest
 183
 184 coreAppTy :: Parser Ty
 185 coreAppTy = do
 186   bTy <- try coreBty
 187   whiteSpace
 188   aTy <- try coreAty
 189   return $ Tapp bTy aTy
 190
 191 coreAty = try coreTcon <|> try coreTvar <|> parens coreType
 192
 193 coreTvar :: Parser Ty
 194 coreTvar = try identifier >>= (return . Tvar)
 195
 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)
 201              >>= (return . Tcon)
 202
 203 coreTyApp :: Parser Ty
 204 coreTyApp = do
 205   operTy <- coreType
 206   randTy <- coreType
 207   return $ Tapp operTy randTy
 208
 209 coreFunTy :: Parser Ty
 210 coreFunTy = do
 211   argTy <- coreBty
 212   whiteSpace
 213   symbol "->"
 214   whiteSpace
 215   resTy <- coreType
 216   return $ tArrow argTy resTy
 217
 218 coreForallTy :: Parser Ty
 219 coreForallTy = do
 220   reserved "forall"
 221   tBinds <- many1 coreTbind
 222   symbol "."
 223   bodyTy <- coreType
 224   return $ foldr Tforall bodyTy tBinds
 225
 226 -- TODO: similar to coreType. should refactor
 227 coreKind :: Parser Kind
 228 coreKind = do
 229   hd <- coreAtomicKind
 230   maybeRest <- option [] (many1 (symbol "->" >> coreKind))
 231   return $ case maybeRest of
 232              [] -> hd
 233              stuff -> foldl Karrow hd maybeRest
 234
 235 coreAtomicKind = try liftedKind <|> try unliftedKind
 236        <|> try openKind <|> try (parens equalityKind)
 237        <|> try (parens coreKind)
 238
 239 liftedKind = do
 240   symbol "*"
 241   return Klifted
 242
 243 unliftedKind = do
 244   symbol "#"
 245   return Kunlifted
 246
 247 openKind = do
 248   symbol "?"
 249   return Kopen
 250
 251 equalityKind = do
 252   ty1 <- coreBty
 253   symbol ":=:"
 254   ty2 <- coreBty
 255   return $ Keq ty1 ty2
 256 coreVdefGroups :: Parser [Vdefg]
 257 coreVdefGroups = option [] (do
 258   theFirstVdef <- coreVdefg
 259   symbol ";"
 260   others <- coreVdefGroups
 261   return $ theFirstVdef:others)
 262
 263 coreVdefg :: Parser Vdefg
 264 coreVdefg = coreRecVdef <|> coreNonrecVdef
 265
 266 coreRecVdef = do
 267   reserved "rec"
 268   braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
 269
 270 coreNonrecVdef = coreVdef >>= (return . Nonrec)
 271
 272 coreVdef = do
 273   (vdefLhs, vdefTy) <- topVbind
 274   whiteSpace
 275   symbol "="
 276   whiteSpace
 277   vdefRhs  <- coreFullExp
 278   return $ Vdef (vdefLhs, vdefTy, vdefRhs)
 279
 280 coreAtomicExp :: Parser Exp
 281 coreAtomicExp = do
 282 -- For stupid reasons, the whiteSpace is necessary.
 283 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
 284   whiteSpace
 285   res <- choice [ try coreVar,
 286                     coreDcon,
 287                     try coreLit,
 288                     parens coreFullExp ]
 289   whiteSpace
 290   return res
 291
 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)
 296     <|> coreAtomicExp
 297
 298 coreAppExp = do
 299 -- notes:
 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
 305     whiteSpace
 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
 312
 313 coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual)))
 314              >>= (return . Var)
 315 coreDcon = coreQualifiedCon >>= (return . Dcon)
 316
 317 coreLit :: Parser Exp
 318 coreLit = parens (coreLiteral >>= (return . Lit))
 319
 320 coreLiteral :: Parser Lit
 321 coreLiteral = do
 322   l <- try aLit
 323   symbol "::"
 324   t <- coreType
 325   return $ Literal l t
 326
 327 coreLam = do
 328   symbol "\\"
 329   binds <- coreLambdaBinds
 330   symbol "->"
 331   body <- coreFullExp
 332   return $ foldr Lam body binds
 333 coreLet = do
 334   reserved "let"
 335   vdefg <- coreVdefg
 336   whiteSpace
 337   reserved "in"
 338   body <- coreFullExp
 339   return $ Let vdefg body
 340 coreCase = do
 341   reserved "case"
 342   ty <- coreAty
 343   scrut <- coreAtomicExp
 344   reserved "of"
 345   vBind <- parens lambdaBind
 346   alts <- coreAlts
 347   return $ Case scrut vBind ty alts
 348 coreCast = do
 349   reserved "cast"
 350   whiteSpace
 351 -- The parens are CRUCIAL, o/w it's ambiguous
 352   body <- try (parens coreFullExp)
 353   whiteSpace
 354   ty <- try coreAty
 355   return $ Cast body ty
 356 coreNote = do
 357   reserved "note"
 358   s <- stringLiteral
 359   e <- coreFullExp
 360   return $ Note s e
 361 coreExternal = do
 362   reserved "external"
 363   -- TODO: This isn't in the grammar, but GHC
 364   -- always prints "external ccall". investigate...
 365   symbol "ccall"
 366   s <- stringLiteral
 367   t <- coreAty
 368   return $ External s t
 369
 370 coreLambdaBinds = many1 coreBind
 371
 372 coreBind = coreTbinding <|> coreVbind
 373
 374 coreTbinding = try coreAtTbind >>= (return . Tb)
 375 coreVbind = parens (lambdaBind >>= (return . Vb))
 376
 377 coreAtTbind = (symbol "@") >> coreTbind
 378
 379 topVbind   = aCoreVbind coreQualifiedName
 380 lambdaBind = aCoreVbind identifier
 381
 382 aCoreVbind idP =  do
 383   nm <- idP
 384   symbol "::"
 385   t <- coreType
 386   return (nm, t)
 387
 388
 389 aLit :: Parser CoreLit
 390 aLit = intOrRatLit <|> charLit <|> stringLit
 391
 392 intOrRatLit :: Parser CoreLit
 393 intOrRatLit = do
 394  -- Int and lit combined into one to avoid ambiguity.
 395  -- Argh....
 396   lhs <- anIntLit
 397   maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
 398   case maybeRhs of
 399     Nothing  -> return $ Lint lhs
 400     Just rhs -> return $ Lrational (lhs % rhs)
 401
 402 anIntLit :: Parser Integer
 403 anIntLit = do
 404   sign <- option 1 (symbol "-" >> return (-1))
 405   n <- natural
 406   return (sign * n)
 407
 408 charLit :: Parser CoreLit
 409 charLit = charLiteral >>= (return . Lchar)
 410  -- make sure this is right
 411
 412 stringLit :: Parser CoreLit
 413 stringLit = stringLiteral >>= (return . Lstring)
 414  -- make sure this is right
 415
 416 coreAlts :: Parser [Alt]
 417 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
 418
 419 coreAlt :: Parser Alt
 420 coreAlt = conAlt <|> litAlt <|> defaultAlt
 421
 422 conAlt :: Parser Alt
 423 conAlt = do
 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)
 428   whiteSpace
 429   try (symbol "->")
 430   rhs     <- try coreFullExp
 431   return $ Acon conName tBinds vBinds rhs
 432
 433 litAlt :: Parser Alt
 434 litAlt = do
 435   l <- parens coreLiteral
 436   symbol "->"
 437   rhs <- coreFullExp
 438   return $ Alit l rhs
 439
 440 defaultAlt :: Parser Alt
 441 defaultAlt = do
 442   reserved "_"
 443   symbol "->"
 444   rhs <- coreFullExp
 445   return $ Adefault rhs
 446 ----------------
 447 extCore = P.makeTokenParser extCoreDef
 448
 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
 461
 462 -- dodgy since Core doesn't really allow comments,
 463 -- but we'll pretend...
 464 extCoreDef = LanguageDef {
 465       commentStart    = "{-"
 466     , commentEnd      = "-}"
 467     , commentLine     = "--"
 468     , nestedComments  = True
 469     , identStart      = lower
 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 = [";", "=", "@", "::", "\\", "%_",
 478                           ".", "*", "#", "?"]
 479     , caseSensitive   = True
 480     }
 481
 482 -- Stuff to help with testing in ghci.
 483 pTest (Left a) = error (show a)
 484 pTest (Right t) = print t
 485
 486 pTest1 :: Show a => CharParser () a -> String -> IO ()
 487 pTest1 pr s = do
 488   let res = parse pr "" s
 489   pTest res
 490
 491 pt :: Show a => CharParser () a -> String -> IO ()
 492 pt pr s = do
 493   x <- parseTest pr s
 494   print x
 495
 496 try_ = try
 497 many_ = many
 498 option_ = option
 499 many1_ = many1
 500 il = identLetter
 501
 502 andThenSym a b = do
 503   p <- a
 504   symbol b
 505   return p