utils/ext-core/ParsecParser.hs

   1 {-# OPTIONS -Wall -Werror -fno-warn-missing-signatures #-}
   2
   3 module ParsecParser where
   4
   5 import Core
   6 import ParseGlue
   7 import Check
   8 import PrimCoercions
   9
  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
  14 import Data.Ratio
  15
  16 parseCore :: FilePath -> IO (Either ParseError Module)
  17 parseCore = parseFromFile coreModule
  18
  19 coreModule :: Parser Module
  20 coreModule = do
  21    whiteSpace
  22    reserved "module"
  23    mName      <- coreModuleName
  24    whiteSpace
  25    tdefs      <- option [] coreTdefs
  26    vdefGroups <- coreVdefGroups
  27    eof
  28    return $ Module mName tdefs vdefGroups
  29
  30 coreModuleName :: Parser AnMname
  31 coreModuleName = do
  32    pkgName      <- corePackageName
  33    char ':'
  34    (modHierarchy,baseName) <- coreHierModuleNames
  35    return (pkgName, modHierarchy, baseName)
  36
  37 corePackageName :: Parser Pname
  38 -- Package names can be lowercase or uppercase!
  39 -- TODO: update docs
  40 corePackageName = identifier <|> upperName
  41
  42 coreHierModuleNames :: Parser ([Id], Id)
  43 coreHierModuleNames = do
  44    parentName <- upperName
  45    return $ splitModuleName parentName
  46
  47 upperName :: Parser Id
  48 upperName = do
  49    firstChar <- upper
  50    rest <- many (identLetter extCoreDef)
  51    return $ firstChar:rest
  52
  53 coreTdefs :: Parser [Tdef]
  54 coreTdefs = many coreTdef
  55
  56 coreTdef :: Parser Tdef
  57 coreTdef = withSemi (try (try coreDataDecl <|> try coreNewtypeDecl))
  58
  59
  60 withSemi p = try p `withTerminator` ";"
  61
  62 withTerminator p term = do
  63    x <- try p
  64    try $ symbol term
  65    return x
  66
  67 coreDataDecl :: Parser Tdef
  68 coreDataDecl = do
  69   reserved "data"
  70   tyCon  <- coreQualifiedCon
  71   whiteSpace -- important
  72   tBinds <- coreTbinds
  73   whiteSpace
  74   symbol "="
  75   whiteSpace
  76   cDefs  <- braces coreCdefs
  77   return $ Data tyCon tBinds cDefs
  78
  79 coreNewtypeDecl :: Parser Tdef
  80 coreNewtypeDecl = do
  81   reserved "newtype"
  82   tyCon  <- coreQualifiedCon
  83   whiteSpace
  84   tBinds <- coreTbinds
  85   symbol "^"
  86   axiom <- coreAxiom
  87   tyRep  <- try coreTRep
  88   return $ Newtype tyCon tBinds axiom tyRep
  89
  90 coreQualifiedCon :: Parser (Mname, Id)
  91 coreQualifiedCon = coreQualifiedGen upperName
  92
  93 coreQualifiedName = coreQualifiedGen identifier
  94
  95 coreQualifiedGen p = do
  96   maybeMname <- coreMaybeMname
  97   theId      <- p
  98   return (maybeMname, theId)
  99
 100 coreMaybeMname = optionMaybe coreMname
 101
 102 coreRequiredQualifiedName = do
 103   mname <- coreMname
 104   theId <- identifier
 105   return (Just mname, theId)
 106
 107 coreMname = do
 108 -- Notice the '^' goes here:
 109 -- it's part of a variable *occurrence*, not a module name.
 110   char '^'
 111   nm <- try coreModuleName
 112   symbol "."
 113   return nm
 114
 115 coreAxiom :: Parser Axiom
 116 coreAxiom = parens (do
 117               coercionName <- coreQualifiedCon
 118               whiteSpace
 119               tbs <- coreTbinds
 120               whiteSpace
 121               symbol "::"
 122               whiteSpace
 123               coercionK <- try equalityKind <|> parens equalityKind
 124               return (coercionName, tbs, coercionK))
 125
 126 coreTbinds :: Parser [Tbind]
 127 coreTbinds = many coreTbind
 128
 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)
 134
 135 coreTbind :: Parser Tbind
 136 coreTbind = coreTbindGen whiteSpace
 137
 138 coreTbindGen :: CharParser () a -> Parser Tbind
 139 coreTbindGen sep = (parens (do
 140                      sep
 141                      tyVar <- identifier
 142                      kind <- symbol "::" >> coreKind
 143                      return (tyVar, kind))) <|>
 144                     (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
 145
 146 coreCdefs :: Parser [Cdef]
 147 coreCdefs = sepBy1 coreCdef (symbol ";")
 148
 149 coreCdef :: Parser Cdef
 150 coreCdef = do
 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
 158
 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
 163               symbol "="
 164               try coreType)
 165
 166 coreType :: Parser Ty
 167 coreType = coreForallTy <|> (do
 168              hd <- coreBty
 169              -- whiteSpace is important!
 170              whiteSpace
 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
 175                          [] -> hd
 176                          stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
 177
 178 coreBty :: Parser Ty
 179 coreBty = do
 180   hd <- coreAty
 181                          -- The "try" is necessary:
 182                          -- otherwise, parsing "T " fails rather
 183                          -- than returning "T".
 184   maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
 185   return $ (case hd of
 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
 189              -- forces it.
 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
 197                        app _ _ args err =
 198                            primCoercionError (err ++
 199                              ("Args were: " ++ show args))
 200
 201 coreAtySaturated :: Parser Ty
 202 coreAtySaturated = do
 203    t <- coreAty
 204    case t of
 205      ATy ty -> return ty
 206      _     -> unexpected "coercion ty"
 207
 208 coreAty :: Parser ATyOp
 209 coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
 210                              >>= return . ATy)
 211 coreTvar :: Parser Ty
 212 coreTvar = try identifier >>= (return . Tvar)
 213
 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
 218 coreTcon =
 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.
 222         try (do
 223                                     -- the "try"s are crucial; they force
 224                                     -- backtracking
 225            maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
 226                                     try leftCo, rightCo]
 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))
 234
 235 data CoercionTy = TransC | SymC | UnsafeC | LeftC | RightC
 236
 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
 244
 245 coreFunTy :: Parser Ty
 246 coreFunTy = do
 247   argTy <- coreBty
 248   whiteSpace
 249   symbol "->"
 250   whiteSpace
 251   resTy <- coreType
 252   return $ tArrow argTy resTy
 253
 254 coreForallTy :: Parser Ty
 255 coreForallTy = do
 256   reserved "forall"
 257   tBinds <- many1 coreTbind
 258   symbol "."
 259   bodyTy <- coreType
 260   return $ foldr Tforall bodyTy tBinds
 261
 262 -- TODO: similar to coreType. should refactor
 263 coreKind :: Parser Kind
 264 coreKind = do
 265   hd <- coreAtomicKind
 266   maybeRest <- option [] (many1 (symbol "->" >> coreKind))
 267   return $ foldl Karrow hd maybeRest
 268
 269 coreAtomicKind = try liftedKind <|> try unliftedKind
 270        <|> try openKind {- <|> try (parens equalityKind) -}
 271        <|> try (parens coreKind)
 272
 273 liftedKind = do
 274   symbol "*"
 275   return Klifted
 276
 277 unliftedKind = do
 278   symbol "#"
 279   return Kunlifted
 280
 281 openKind = do
 282   symbol "?"
 283   return Kopen
 284
 285 equalityKind = do
 286   ty1 <- coreBty
 287   symbol ":=:"
 288   ty2 <- coreBty
 289   return (ty1, ty2)
 290
 291 -- Only used internally within the parser:
 292 -- represents either a Tcon, or a continuation
 293 -- for a primitive coercion
 294 data ATyOp =
 295    ATy Ty
 296  | Trans ([Ty] -> Ty)
 297  | Sym ([Ty] -> Ty)
 298  | Unsafe ([Ty] -> Ty)
 299  | LeftCo ([Ty] -> Ty)
 300  | RightCo ([Ty] -> Ty)
 301
 302 coreVdefGroups :: Parser [Vdefg]
 303 coreVdefGroups = option [] (do
 304   theFirstVdef <- coreVdefg
 305   symbol ";"
 306   others <- coreVdefGroups
 307   return $ theFirstVdef:others)
 308
 309 coreVdefg :: Parser Vdefg
 310 coreVdefg = coreRecVdef <|> coreNonrecVdef
 311
 312 coreRecVdef = do
 313   reserved "rec"
 314   braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
 315
 316 coreNonrecVdef = coreVdef >>= (return . Nonrec)
 317
 318 coreVdef = do
 319   (vdefLhs, vdefTy) <- topVbind
 320   whiteSpace
 321   symbol "="
 322   whiteSpace
 323   vdefRhs  <- coreFullExp
 324   return $ Vdef (vdefLhs, vdefTy, vdefRhs)
 325
 326 coreAtomicExp :: Parser Exp
 327 coreAtomicExp = do
 328 -- For stupid reasons, the whiteSpace is necessary.
 329 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
 330   whiteSpace
 331   res <- choice [ try coreVar,
 332                     coreDcon,
 333                     try coreLit,
 334                     parens coreFullExp ]
 335   whiteSpace
 336   return res
 337
 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)
 342     <|> coreAtomicExp
 343
 344 coreAppExp = do
 345 -- notes:
 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
 351     whiteSpace
 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
 358
 359 coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual)))
 360              >>= (return . Var)
 361 coreDcon = coreQualifiedCon >>= (return . Dcon)
 362
 363 coreLit :: Parser Exp
 364 coreLit = parens (coreLiteral >>= (return . Lit))
 365
 366 coreLiteral :: Parser Lit
 367 coreLiteral = do
 368   l <- try aLit
 369   symbol "::"
 370   t <- coreType
 371   return $ Literal l t
 372
 373 coreLam = do
 374   symbol "\\"
 375   binds <- coreLambdaBinds
 376   symbol "->"
 377   body <- coreFullExp
 378   return $ foldr Lam body binds
 379 coreLet = do
 380   reserved "let"
 381   vdefg <- coreVdefg
 382   whiteSpace
 383   reserved "in"
 384   body <- coreFullExp
 385   return $ Let vdefg body
 386 coreCase = do
 387   reserved "case"
 388   ty <- coreAtySaturated
 389   scrut <- coreAtomicExp
 390   reserved "of"
 391   vBind <- parens lambdaBind
 392   alts <- coreAlts
 393   return $ Case scrut vBind ty alts
 394 coreCast = do
 395   reserved "cast"
 396   whiteSpace
 397 -- The parens are CRUCIAL, o/w it's ambiguous
 398   body <- try (parens coreFullExp)
 399   whiteSpace
 400   ty <- try coreAtySaturated
 401   return $ Cast body ty
 402 coreNote = do
 403   reserved "note"
 404   s <- stringLiteral
 405   e <- coreFullExp
 406   return $ Note s e
 407 coreExternal = (do
 408   reserved "external"
 409   -- TODO: This isn't in the grammar, but GHC
 410   -- always prints "external ccall". investigate...
 411   symbol "ccall"
 412   s <- stringLiteral
 413   t <- coreAtySaturated
 414   return $ External s t) <|>
 415     -- TODO: I don't really understand what this does
 416                 (do
 417     reserved "dynexternal"
 418     symbol "ccall"
 419     t <- coreAtySaturated
 420     return $ External "[dynamic]" t)
 421 coreLabel = do
 422 -- TODO: Totally punting this, but it needs to go in the grammar
 423 -- or not at all
 424   reserved "label"
 425   s <- stringLiteral
 426   return $ External s tAddrzh
 427
 428 coreLambdaBinds = many1 coreBind
 429
 430 coreBind = coreTbinding <|> coreVbind
 431
 432 coreTbinding = try coreAtTbind >>= (return . Tb)
 433 coreVbind = parens (lambdaBind >>= (return . Vb))
 434
 435 coreAtTbind = (symbol "@") >> coreTbind
 436
 437 topVbind   = aCoreVbind coreQualifiedName
 438 lambdaBind = aCoreVbind identifier
 439
 440 aCoreVbind idP =  do
 441   nm <- idP
 442   symbol "::"
 443   t <- coreType
 444   return (nm, t)
 445
 446
 447 aLit :: Parser CoreLit
 448 aLit = intOrRatLit <|> charLit <|> stringLit
 449
 450 intOrRatLit :: Parser CoreLit
 451 intOrRatLit = do
 452  -- Int and lit combined into one to avoid ambiguity.
 453  -- Argh....
 454   lhs <- anIntLit
 455   maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
 456   case maybeRhs of
 457     Nothing  -> return $ Lint lhs
 458     Just rhs -> return $ Lrational (lhs % rhs)
 459
 460 anIntLit :: Parser Integer
 461 anIntLit = do
 462   sign <- option 1 (symbol "-" >> return (-1))
 463   n <- natural
 464   return (sign * n)
 465
 466 charLit :: Parser CoreLit
 467 charLit = charLiteral >>= (return . Lchar)
 468  -- make sure this is right
 469
 470 stringLit :: Parser CoreLit
 471 stringLit = stringLiteral >>= (return . Lstring)
 472  -- make sure this is right
 473
 474 coreAlts :: Parser [Alt]
 475 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
 476
 477 coreAlt :: Parser Alt
 478 coreAlt = conAlt <|> litAlt <|> defaultAlt
 479
 480 conAlt :: Parser Alt
 481 conAlt = do
 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)
 486   whiteSpace
 487   try (symbol "->")
 488   rhs     <- try coreFullExp
 489   return $ Acon conName tBinds vBinds rhs
 490
 491 litAlt :: Parser Alt
 492 litAlt = do
 493   l <- parens coreLiteral
 494   symbol "->"
 495   rhs <- coreFullExp
 496   return $ Alit l rhs
 497
 498 defaultAlt :: Parser Alt
 499 defaultAlt = do
 500   reserved "_"
 501   symbol "->"
 502   rhs <- coreFullExp
 503   return $ Adefault rhs
 504 ----------------
 505 extCore = P.makeTokenParser extCoreDef
 506
 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
 519
 520 -- dodgy since Core doesn't really allow comments,
 521 -- but we'll pretend...
 522 extCoreDef = LanguageDef {
 523       commentStart    = "{-"
 524     , commentEnd      = "-}"
 525     , commentLine     = "--"
 526     , nestedComments  = True
 527     , identStart      = lower
 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 = [";", "=", "@", "::", "\\", "%_",
 536                           ".", "*", "#", "?"]
 537     , caseSensitive   = True
 538     }
 539
 540 -- Stuff to help with testing in ghci.
 541 pTest (Left a) = error (show a)
 542 pTest (Right t) = print t
 543
 544 pTest1 :: Show a => CharParser () a -> String -> IO ()
 545 pTest1 pr s = do
 546   let res = parse pr "" s
 547   pTest res
 548
 549 pt :: Show a => CharParser () a -> String -> IO ()
 550 pt pr s = do
 551   x <- parseTest pr s
 552   print x
 553
 554 try_ = try
 555 many_ = many
 556 option_ = option
 557 many1_ = many1
 558 il = identLetter
 559
 560 andThenSym a b = do
 561   p <- a
 562   symbol b
 563   return p