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