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