utils/ext-core/ParsecParser.hs

   1 {-# OPTIONS -Wall -fno-warn-missing-signatures #-}
   2
   3 module ParsecParser (parseCore) where
   4
   5 import Core
   6 import ParseGlue
   7 import Check
   8 import PrimCoercions
   9
  10 import Text.ParserCombinators.Parsec
  11 import qualified Text.ParserCombinators.Parsec.Token as P
  12 import Text.ParserCombinators.Parsec.Language
  13 import Data.Char
  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 $ M (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 :: Parser String -> Parser (Mname, Id)
  96 coreQualifiedGen p = (try (do
  97   packageIdOrVarName <- corePackageName
  98   maybeRest <- optionMaybe (char ':' >> coreHierModuleNames)
  99   case maybeRest of
 100                -- unqualified id, so backtrack
 101     Nothing -> pzero
 102                -- qualified name, so look for the id part
 103     Just (modHierarchy, baseName) -> do
 104                char '.'
 105                theId <- p
 106                return
 107                  (Just $ M (packageIdOrVarName, modHierarchy, baseName),
 108                   theId))) <|>
 109    -- unqualified name
 110    (p >>= (\ res -> return (Nothing, res)))
 111
 112 {-
 113 coreMaybeMname = optionMaybe coreMname
 114
 115 coreRequiredQualifiedName = do
 116   mname <- coreMname
 117   theId <- identifier
 118   return (Just mname, theId)
 119
 120 coreMname = do
 121   char '^'
 122   nm <- try coreModuleName
 123   symbol "."
 124   return nm
 125 -}
 126
 127 coreAxiom :: Parser Axiom
 128 coreAxiom = parens (do
 129               coercionName <- coreQualifiedCon
 130               whiteSpace
 131               tbs <- coreTbinds
 132               whiteSpace
 133               symbol "::"
 134               whiteSpace
 135               coercionK <- try equalityKind <|> parens equalityKind
 136               return (coercionName, tbs, coercionK))
 137
 138 coreTbinds :: Parser [Tbind]
 139 coreTbinds = many coreTbind
 140
 141 coreTbindsGen :: CharParser () String -> Parser [Tbind]
 142 -- The "try" here is important. Otherwise, when parsing:
 143 -- "Node (^base:DataziTuple.Z3T)" (a cdef), we commit to
 144 -- parsing (^base...) as a tbind rather than a type.
 145 coreTbindsGen separator = many (try $ coreTbindGen separator)
 146
 147 coreTbind :: Parser Tbind
 148 coreTbind = coreTbindGen whiteSpace
 149
 150 coreTbindGen :: CharParser () a -> Parser Tbind
 151 coreTbindGen sep = (parens (do
 152                      sep
 153                      tyVar <- identifier
 154                      kind <- symbol "::" >> coreKind
 155                      return (tyVar, kind))) <|>
 156                     (sep >> identifier >>= (return . (\ tv -> (tv,Klifted))))
 157
 158 coreCdefs :: Parser [Cdef]
 159 coreCdefs = sepBy1 coreCdef (symbol ";")
 160
 161 coreCdef :: Parser Cdef
 162 coreCdef = do
 163   dataConName <- coreQualifiedCon
 164   whiteSpace -- important!
 165   tBinds      <- try $ coreTbindsGen (symbol "@")
 166   -- This should be equivalent to (many coreAty)
 167   -- But it isn't. WHY??
 168   tys         <- sepBy coreAtySaturated whiteSpace
 169   return $ Constr dataConName tBinds tys
 170
 171 coreTRep :: Parser (Maybe Ty)
 172 -- note that the "=" is inside here since if there's
 173 -- no rhs for the newtype, there's no "="
 174 coreTRep = optionMaybe (do
 175               symbol "="
 176               try coreType)
 177
 178 coreType :: Parser Ty
 179 coreType = coreForallTy <|> (do
 180              hd <- coreBty
 181              -- whiteSpace is important!
 182              whiteSpace
 183              -- This says: If there is at least one ("-> ty"..) thing,
 184              -- use it. If not, don't consume any input.
 185              maybeRest <- option [] (many1 (symbol "->" >> coreType))
 186              return $ case maybeRest of
 187                          [] -> hd
 188                          stuff -> foldl Tapp (Tcon tcArrow) (hd:stuff))
 189
 190 coreBty :: Parser Ty
 191 coreBty = do
 192   hd <- coreAty
 193                          -- The "try" is necessary:
 194                          -- otherwise, parsing "T " fails rather
 195                          -- than returning "T".
 196   maybeRest <- option [] (many1 (try (whiteSpace >> coreAtySaturated)))
 197   return $ (case hd of
 198              -- so I'm not sure I like this... it's basically doing
 199              -- typechecking (kind-checking?) in the parser.
 200              -- However, the type syntax as defined in Core.hs sort of
 201              -- forces it.
 202              ATy t     -> foldl Tapp t maybeRest
 203              Trans k   -> app k 2 maybeRest "trans"
 204              Sym k     -> app k 1 maybeRest "sym"
 205              Unsafe k  -> app k 2 maybeRest "unsafe"
 206              LeftCo k  -> app k 1 maybeRest "left"
 207              RightCo k -> app k 1 maybeRest "right")
 208                  where app k arity args _ | length args == arity = k args
 209                        app _ _ args err =
 210                            primCoercionError (err ++
 211                              ("Args were: " ++ show args))
 212
 213 coreAtySaturated :: Parser Ty
 214 coreAtySaturated = do
 215    t <- coreAty
 216    case t of
 217      ATy ty -> return ty
 218      _     -> unexpected "coercion ty"
 219
 220 coreAty :: Parser ATyOp
 221 coreAty = try coreTcon <|> ((try coreTvar <|> parens coreType)
 222                              >>= return . ATy)
 223 coreTvar :: Parser Ty
 224 coreTvar = try identifier >>= (return . Tvar)
 225
 226 coreTcon :: Parser ATyOp
 227 -- TODO: Change the grammar
 228 -- A Tcon can be an uppercase type constructor
 229 -- or a lowercase (always qualified) coercion variable
 230 coreTcon =
 231          -- Special case is first so that (CoUnsafe .. ..) gets parsed as
 232          -- a prim. coercion app and not a Tcon app.
 233          -- But the whole thing is so bogus.
 234         try (do
 235                                     -- the "try"s are crucial; they force
 236                                     -- backtracking
 237            maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
 238                                     try leftCo, rightCo]
 239            return $ case maybeCoercion of
 240               TransC  -> Trans (\ [x,y] -> TransCoercion x y)
 241               SymC    -> Sym (\ [x] -> SymCoercion x)
 242               UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
 243               LeftC   -> LeftCo (\ [x] -> LeftCoercion x)
 244               RightC  -> RightCo (\ [x] -> RightCoercion x))
 245     <|> (coreQualifiedCon >>= (return . ATy . Tcon))
 246
 247 data CoercionTy = TransC | SymC | UnsafeC | LeftC | RightC
 248
 249 symCo, transCo, unsafeCo :: Parser CoercionTy
 250 -- Would be better not to wire these in quite this way. Sigh
 251 symCo    = string "ghczmprim:GHCziPrim.sym"      >> return SymC
 252 transCo  = string "ghczmprim:GHCziPrim.trans"    >> return TransC
 253 unsafeCo = string "ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC
 254 leftCo   = string "ghczmprim:GHCziPrim.left"     >> return LeftC
 255 rightCo  = string "ghczmprim:GHCziPrim.right"    >> return RightC
 256
 257 coreForallTy :: Parser Ty
 258 coreForallTy = do
 259   reserved "forall"
 260   tBinds <- many1 coreTbind
 261   symbol "."
 262   bodyTy <- coreType
 263   return $ foldr Tforall bodyTy tBinds
 264
 265 -- TODO: similar to coreType. should refactor
 266 coreKind :: Parser Kind
 267 coreKind = do
 268   hd <- coreAtomicKind
 269   maybeRest <- option [] (many1 (symbol "->" >> coreKind))
 270   return $ foldl Karrow hd maybeRest
 271
 272 coreAtomicKind = try liftedKind <|> try unliftedKind
 273        <|> try openKind {- <|> try (parens equalityKind) -}
 274        <|> try (parens coreKind)
 275
 276 liftedKind = do
 277   symbol "*"
 278   return Klifted
 279
 280 unliftedKind = do
 281   symbol "#"
 282   return Kunlifted
 283
 284 openKind = do
 285   symbol "?"
 286   return Kopen
 287
 288 equalityKind = do
 289   ty1 <- coreBty
 290   symbol ":=:"
 291   ty2 <- coreBty
 292   return (ty1, ty2)
 293
 294 -- Only used internally within the parser:
 295 -- represents either a Tcon, or a continuation
 296 -- for a primitive coercion
 297 data ATyOp =
 298    ATy Ty
 299  | Trans ([Ty] -> Ty)
 300  | Sym ([Ty] -> Ty)
 301  | Unsafe ([Ty] -> Ty)
 302  | LeftCo ([Ty] -> Ty)
 303  | RightCo ([Ty] -> Ty)
 304
 305 coreVdefGroups :: Parser [Vdefg]
 306 coreVdefGroups = option [] (do
 307   theFirstVdef <- coreVdefg
 308   symbol ";"
 309   others <- coreVdefGroups
 310   return $ theFirstVdef:others)
 311
 312 coreVdefg :: Parser Vdefg
 313 coreVdefg = coreRecVdef <|> coreNonrecVdef
 314
 315 coreRecVdef = do
 316   reserved "rec"
 317   braces (sepBy1 coreVdef (symbol ";")) >>= (return . Rec)
 318
 319 coreNonrecVdef = coreVdef >>= (return . Nonrec)
 320
 321 coreVdef = do
 322   (vdefLhs, vdefTy) <- try topVbind <|> (do
 323                         (v, ty) <- lambdaBind
 324                         return (unqual v, ty))
 325   whiteSpace
 326   symbol "="
 327   whiteSpace
 328   vdefRhs  <- coreFullExp
 329   return $ Vdef (vdefLhs, vdefTy, vdefRhs)
 330
 331 coreAtomicExp :: Parser Exp
 332 coreAtomicExp = do
 333 -- For stupid reasons, the whiteSpace is necessary.
 334 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
 335   whiteSpace
 336   res <- choice [try coreDconOrVar,
 337                     try coreLit,
 338                     parens coreFullExp ]
 339   whiteSpace
 340   return res
 341
 342 coreFullExp = (choice [coreLam, coreLet,
 343   coreCase, coreCast, coreNote, coreExternal, coreLabel]) <|> (try coreAppExp)
 344 -- The "try" is necessary so that we backtrack
 345 -- when we see a var (that is not an app)
 346     <|> coreAtomicExp
 347
 348 coreAppExp = do
 349 -- notes:
 350 -- it's important to have a separate coreAtomicExp (that any app exp
 351 -- begins with) and to define the args in terms of many1.
 352 -- previously, coreAppExp could parse either an atomic exp (an app with
 353 -- 0 arguments) or an app with >= 1 arguments, but that led to ambiguity.
 354     oper <- try coreAtomicExp
 355     whiteSpace
 356     args <- many1 (whiteSpace >> ((coreAtomicExp >>= (return . Left)) <|>
 357              -- note this MUST be coreAty, not coreType, because otherwise:
 358              -- "A @ B c" gets parsed as "A @ (B c)"
 359              ((symbol "@" >> coreAtySaturated) >>= (return . Right))))
 360     return $ foldl (\ op ->
 361                      either (App op) (Appt op)) oper args
 362
 363 coreDconOrVar = do
 364   theThing <- coreQualifiedGen (try upperName <|> identifier)
 365   return $ case theThing of
 366     -- note that data constructors must be qualified
 367     (Just _, idItself) | isUpper (head idItself)
 368       -> Dcon theThing
 369     _ -> Var theThing
 370
 371 coreLit :: Parser Exp
 372 coreLit = parens (coreLiteral >>= (return . Lit))
 373
 374 coreLiteral :: Parser Lit
 375 coreLiteral = do
 376   l <- try aLit
 377   symbol "::"
 378   t <- coreType
 379   return $ Literal l t
 380
 381 coreLam = do
 382   symbol "\\"
 383   binds <- coreLambdaBinds
 384   symbol "->"
 385   body <- coreFullExp
 386   return $ foldr Lam body binds
 387 coreLet = do
 388   reserved "let"
 389   vdefg <- coreVdefg
 390   whiteSpace
 391   reserved "in"
 392   body <- coreFullExp
 393   return $ Let vdefg body
 394 coreCase = do
 395   reserved "case"
 396   ty <- coreAtySaturated
 397   scrut <- coreAtomicExp
 398   reserved "of"
 399   vBind <- parens lambdaBind
 400   alts <- coreAlts
 401   return $ Case scrut vBind ty alts
 402 coreCast = do
 403   reserved "cast"
 404   whiteSpace
 405 -- The parens are CRUCIAL, o/w it's ambiguous
 406   body <- try (parens coreFullExp)
 407   whiteSpace
 408   ty <- try coreAtySaturated
 409   return $ Cast body ty
 410 coreNote = do
 411   reserved "note"
 412   s <- stringLiteral
 413   e <- coreFullExp
 414   return $ Note s e
 415 coreExternal = (do
 416   reserved "external"
 417   -- TODO: This isn't in the grammar, but GHC
 418   -- always prints "external ccall". investigate...
 419   symbol "ccall"
 420   s <- stringLiteral
 421   t <- coreAtySaturated
 422   return $ External s t) <|>
 423     -- TODO: I don't really understand what this does
 424                 (do
 425     reserved "dynexternal"
 426     symbol "ccall"
 427     t <- coreAtySaturated
 428     return $ External "[dynamic]" t)
 429 coreLabel = do
 430 -- TODO: Totally punting this, but it needs to go in the grammar
 431 -- or not at all
 432   reserved "label"
 433   s <- stringLiteral
 434   return $ External s tAddrzh
 435
 436 coreLambdaBinds = many1 coreBind
 437
 438 coreBind = coreTbinding <|> coreVbind
 439
 440 coreTbinding = try coreAtTbind >>= (return . Tb)
 441 coreVbind = parens (lambdaBind >>= (return . Vb))
 442
 443 coreAtTbind = (symbol "@") >> coreTbind
 444
 445 topVbind :: Parser (Qual Var, Ty)
 446 topVbind   = aCoreVbind coreQualifiedName
 447 lambdaBind :: Parser (Var, Ty)
 448 lambdaBind = aCoreVbind identifier
 449
 450 aCoreVbind idP =  do
 451   nm <- idP
 452   symbol "::"
 453   t <- coreType
 454   return (nm, t)
 455
 456
 457 aLit :: Parser CoreLit
 458 aLit = intOrRatLit <|> charLit <|> stringLit
 459
 460 intOrRatLit :: Parser CoreLit
 461 intOrRatLit = do
 462  -- Int and lit combined into one to avoid ambiguity.
 463  -- Argh....
 464   lhs <- anIntLit
 465   maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
 466   case maybeRhs of
 467     Nothing  -> return $ Lint lhs
 468     Just rhs -> return $ Lrational (lhs % rhs)
 469
 470 anIntLit :: Parser Integer
 471 anIntLit = do
 472   sign <- option 1 (symbol "-" >> return (-1))
 473   n <- natural
 474   return (sign * n)
 475
 476 charLit :: Parser CoreLit
 477 charLit = charLiteral >>= (return . Lchar)
 478  -- make sure this is right
 479
 480 stringLit :: Parser CoreLit
 481 stringLit = stringLiteral >>= (return . Lstring)
 482  -- make sure this is right
 483
 484 coreAlts :: Parser [Alt]
 485 coreAlts = braces $ sepBy1 coreAlt (symbol ";")
 486
 487 coreAlt :: Parser Alt
 488 coreAlt = conAlt <|> litAlt <|> defaultAlt
 489
 490 conAlt :: Parser Alt
 491 conAlt = do
 492   conName <- coreQualifiedCon
 493   tBinds  <- many (parens coreAtTbind)
 494   whiteSpace -- necessary b/c otherwise we parse the next list as empty
 495   vBinds  <- many (parens lambdaBind)
 496   whiteSpace
 497   try (symbol "->")
 498   rhs     <- try coreFullExp
 499   return $ Acon conName tBinds vBinds rhs
 500
 501 litAlt :: Parser Alt
 502 litAlt = do
 503   l <- parens coreLiteral
 504   symbol "->"
 505   rhs <- coreFullExp
 506   return $ Alit l rhs
 507
 508 defaultAlt :: Parser Alt
 509 defaultAlt = do
 510   reserved "_"
 511   symbol "->"
 512   rhs <- coreFullExp
 513   return $ Adefault rhs
 514 ----------------
 515 extCore = P.makeTokenParser extCoreDef
 516
 517 parens          = P.parens extCore
 518 braces          = P.braces extCore
 519 -- newlines are allowed anywhere
 520 whiteSpace      = P.whiteSpace extCore <|> (newline >> return ())
 521 symbol          = P.symbol extCore
 522 identifier      = P.identifier extCore
 523 -- Keywords all begin with '%'
 524 reserved  s     = P.reserved extCore ('%':s)
 525 natural         = P.natural extCore
 526 charLiteral     = P.charLiteral extCore
 527 stringLiteral   = P.stringLiteral extCore
 528
 529 -- dodgy since Core doesn't really allow comments,
 530 -- but we'll pretend...
 531 extCoreDef = LanguageDef {
 532       commentStart    = "{-"
 533     , commentEnd      = "-}"
 534     , commentLine     = "--"
 535     , nestedComments  = True
 536     , identStart      = lower
 537     , identLetter     = lower <|> upper <|> digit <|> (char '\'')
 538     , opStart         = opLetter extCoreDef
 539     , opLetter        = oneOf ";=@:\\%_.*#?%"
 540     , reservedNames   = map ('%' :)
 541                           ["module", "data", "newtype", "rec",
 542                            "let", "in", "case", "of", "cast",
 543                            "note", "external", "forall"]
 544     , reservedOpNames = [";", "=", "@", "::", "\\", "%_",
 545                           ".", "*", "#", "?"]
 546     , caseSensitive   = True
 547     }
 548
 549 {-
 550 -- Stuff to help with testing in ghci.
 551 pTest (Left a) = error (show a)
 552 pTest (Right t) = print t
 553
 554 pTest1 :: Show a => CharParser () a -> String -> IO ()
 555 pTest1 pr s = do
 556   let res = parse pr "" s
 557   pTest res
 558
 559 pt :: Show a => CharParser () a -> String -> IO ()
 560 pt pr s = do
 561   x <- parseTest pr s
 562   print x
 563
 564 try_ = try
 565 many_ = many
 566 option_ = option
 567 many1_ = many1
 568 il = identLetter
 569
 570 andThenSym a b = do
 571   p <- a
 572   symbol b
 573   return p
 574 -}