Text/ParserCombinators/Parsec/examples/Henk/HenkParser.hs

   1 ----------------------------------------------------------------
   2 -- the Henk Parser
   3 -- Copyright 2000, Jan-Willem Roorda and Daan Leijen
   4 ----------------------------------------------------------------
   5 module HenkParser where
   6
   7 import Text.ParserCombinators.Parsec.
   8 import qualified Text.ParserCombinators.Parsec.Token as P
   9 import Text.ParserCombinators.Parsec.Expr
  10 import Text.ParserCombinators.Parsec.Language
  11
  12 import HenkAS
  13
  14 ----------------------------------------------------------------
  15 -- the Henk Parser
  16 --
  17 -- anonymous variables are any identifiers starting with "_"
  18 --
  19 -- unknown types (those that need to be inferred) can explicitly
  20 -- be given using "?"
  21 --
  22 -- instead of grammar: "var : aexpr" as in the henk paper,
  23 -- we use "var : expr" instead. This means that variable
  24 -- sequences as in \, |~|, \/ and /\ expressions need to
  25 -- be comma seperated. Pattern variables are also comma
  26 -- seperated. The case arrow (->) now needs to be (=>) in
  27 -- order to distinguish the end of the pattern from function
  28 -- arrows.
  29 ----------------------------------------------------------------
  30 program
  31     = do{ whiteSpace
  32         ; ts <- semiSep tdecl
  33         ; vs <- semiSep vdecl
  34         ; eof
  35         ; return $ Program ts vs
  36         }
  37
  38 ----------------------------------------------------------------
  39 -- Type declarations
  40 ----------------------------------------------------------------
  41 tdecl
  42     = do{ reserved "data"
  43         ; t  <- bindVar
  44         ; symbol "="
  45         ; ts <- braces (semiSep1 tvar)
  46         ; return $ Data t ts
  47         }
  48
  49 ----------------------------------------------------------------
  50 -- Value declarations
  51 ----------------------------------------------------------------
  52 vdecl :: Parser ValueDecl
  53 vdecl
  54     = do{ reserved "let"
  55         ; b <- bind
  56         ; return $ Let b
  57         }
  58     <|>
  59       do{ reserved "letrec"
  60         ; bs <- braces (semiSep1 bind)
  61         ; return $ LetRec bs
  62         }
  63
  64
  65 bind
  66     = do{ t <- tvar
  67         ; symbol "="
  68         ; e <- expr
  69         ; return $ Bind t e
  70         }
  71
  72 ----------------------------------------------------------------
  73 -- Expressions
  74 ----------------------------------------------------------------
  75 expr :: Parser Expr
  76 expr
  77     = choice
  78       [ letExpr
  79       , forallExpr      -- forall before lambda! \/ vs. \
  80       , lambdaExpr
  81       , piExpr
  82       , caseExpr
  83
  84       , functionExpr
  85       , bigLamdaExpr
  86       ]
  87     <?> "expression"
  88
  89 letExpr
  90     = do{ vd <- vdecl
  91         ; reserved "in"
  92         ; e  <- expr
  93         ; return (In vd e)
  94         }
  95
  96 lambdaExpr
  97     = do{ symbol "\\"
  98         ; ts <- commaSep1 bindVar
  99         ; symbol "."
 100         ; e  <- expr
 101         ; return $ (foldr Lam e ts)
 102         }
 103
 104 piExpr
 105     = do{ symbol "|~|"
 106         ; ts <- commaSep1 bindVar
 107         ; symbol "."
 108         ; e  <- expr
 109         ; return (foldr Pi e ts)
 110         }
 111
 112 ----------------------------------------------------------------
 113 -- Case expressions
 114 ----------------------------------------------------------------
 115 caseExpr
 116     = do{ reserved "case"
 117         ; e <- expr
 118         ; reserved "of"
 119         ; as <- braces (semiSep1 alt)
 120         ; es <- option [] (do{ reserved "at"
 121                              ; braces (semiSep expr)
 122                              })
 123         ; return (Case e as es)
 124         }
 125
 126 alt
 127     = do{ pat <- pattern
 128         ; symbol "=>"
 129         ; e   <- expr
 130         ; return (pat e)
 131         }
 132
 133 pattern
 134     =   do{ p <- atomPattern
 135           ; vs <- commaSep boundVar
 136           ; return (\e -> Alt p (foldr Lam e vs))
 137           }
 138
 139 atomPattern
 140     =   do{ v <- boundVar
 141           ; return (PatVar v)
 142           }
 143     <|> do{ l <- literal
 144           ; return (PatLit l)
 145           }
 146     <?> "pattern"
 147
 148
 149 ----------------------------------------------------------------
 150 -- Syntactic sugar: ->, \/, /\
 151 ----------------------------------------------------------------
 152 functionExpr
 153     = chainr1 appExpr arrow
 154     where
 155       arrow  = do{ symbol "->"
 156                  ; return ((\x y ->
 157                              Pi (TVar anonymous x) y))
 158                  }
 159              <?> ""
 160
 161 bigLamdaExpr
 162     = do{ symbol "/\\"
 163         ; ts <- commaSep1 bindVar
 164         ; symbol "."
 165         ; e  <- expr
 166         ; return (foldr Lam e ts)
 167         }
 168
 169 forallExpr
 170     = do{ try (symbol "\\/")          -- use "try" to try "\" (lambda) too.
 171         ; ts <- commaSep1 bindVar
 172         ; symbol "."
 173         ; e  <- expr
 174         ; return (foldr Pi e ts)
 175         }
 176
 177 ----------------------------------------------------------------
 178 -- Simple expressions
 179 ----------------------------------------------------------------
 180 appExpr
 181     = do{ es <- many1 atomExpr
 182         ; return (foldl1 App es)
 183         }
 184
 185 atomExpr
 186     =   parens expr
 187     <|> do{ v <- boundVar; return (Var v)    }
 188     <|> do{ l <- literal; return (Lit l)}
 189     <|> do{ symbol "*"; return Star     }
 190     <|> do{ symbol "[]"; return Box     }
 191     <|> do{ symbol "?"; return Unknown  }
 192     <?> "simple expression"
 193
 194
 195 ----------------------------------------------------------------
 196 -- Variables & Literals
 197 ----------------------------------------------------------------
 198 variable
 199     = identifier
 200
 201 anonymousVar
 202     = lexeme $
 203       do{ c <- char '_'
 204         ; cs <- many (identLetter henkDef)
 205         ; return (c:cs)
 206         }
 207
 208 bindVar
 209     = do{ i <- variable <|> anonymousVar
 210         ; do{ e <- varType
 211             ; return (TVar i e)
 212             }
 213           <|> return (TVar i Star)
 214         }
 215     <?> "variable"
 216
 217 boundVar
 218     = do{ i <- variable
 219         ; do{ e <- varType
 220             ; return (TVar i e)
 221             }
 222           <|> return (TVar i Unknown)
 223         }
 224     <?> "variable"
 225
 226
 227 tvar
 228     = do{ v <- variable
 229         ; t <- varType
 230         ; return (TVar v t)
 231         }
 232     <?> "typed variable"
 233
 234 varType
 235     = do{ symbol ":"
 236         ; expr
 237         }
 238     <?> "variable type"
 239
 240 literal
 241     = do{ i <- natural
 242         ; return (LitInt i)
 243         }
 244     <?> "literal"
 245
 246
 247 ----------------------------------------------------------------
 248 -- Tokens
 249 ----------------------------------------------------------------
 250 henk            = P.makeTokenParser henkDef
 251
 252 lexeme          = P.lexeme henk
 253 parens          = P.parens henk
 254 braces          = P.braces henk
 255 semiSep         = P.semiSep henk
 256 semiSep1        = P.semiSep1 henk
 257 commaSep        = P.commaSep henk
 258 commaSep1       = P.commaSep1 henk
 259 whiteSpace      = P.whiteSpace henk
 260 symbol          = P.symbol henk
 261 identifier      = P.identifier henk
 262 reserved        = P.reserved henk
 263 natural         = P.natural henk
 264
 265
 266 henkDef
 267     = haskellStyle
 268     { identStart        = letter
 269     , identLetter       = alphaNum <|> oneOf "_'"
 270     , opStart           = opLetter henkDef
 271     , opLetter          = oneOf ":=\\->/|~.*[]"
 272     , reservedOpNames   = ["::","=","\\","->","=>","/\\","\\/"
 273                           ,"|~|",".",":","*","[]"]
 274     , reservedNames     = [ "case", "data", "letrec", "type"
 275                           , "import", "in", "let", "of", "at"
 276                           ]
 277     }