utils/ext-core/Language/Core/ParsecParser.hs

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