maxsharing-1.1: Parser.hs

{-# LANGUAGE UnicodeSyntax #-}
module Parser where

import Lambda
import Prelude.Unicode
import Control.Monad.Identity
import Text.ParserCombinators.Parsec
import Text.Parsec.Prim as P
import Text.Parsec.Language as L
import Text.Parsec.Token as T
import qualified Text.Parsec.IndentParsec as I


langDef ∷ Monad m ⇒ GenLanguageDef String u m
langDef = T.LanguageDef
       {commentStart   = "{-",
        commentEnd     = "-}",
        commentLine    = "--",
        nestedComments = True,
        identStart     = identLetter langDef,
        identLetter    = alphaNum <|> oneOf "_':!#$%&*+/<?@^|-~",
        opStart        = oneOf "",
        opLetter       = oneOf "",
        reservedOpNames= [],
        reservedNames  = ["let","in","λ"],
        caseSensitive  = True}

lexer ∷ Monad m ⇒ I.IndentTokenParser String u m
lexer = T.makeTokenParser langDef

type IndentParser a = I.IndentParsecT String () Identity a

parse ∷ String → Λ
parse input = either (error ∘ show) id $ runIdentity $ I.runGIPT parser () "" "input"

parseFile ∷ FilePath → IO Λ
parseFile path = do
	input ← readFile path
	return $ either (error ∘ show) id $ runIdentity $ I.runGIPT parser () path input

parser ∷ IndentParser Λ
parser = expression <* eof where

	expression = application <|> letBinding <?> "expression"

	application = foldl1 A <$> many1 (parenthetic <|> abstraction <|> variable)

	parenthetic = I.parens lexer expression

	abstraction = flip label "abstraction" $ do
		vars ← (sym "λ" <|> sym "\\") *> many1 ident
		body ← (sym "." <|> sym "→" <|> sym "->") *> expression
		return $ foldr Λ body vars

	variable = fmap V $ ident <|> show <$> I.natural lexer

	letBinding = flip label "let binding" $ do
		(bs, maybe_e) ← sym "let" *> I.blockOf bindings
		e ← case maybe_e of
			Nothing → sym "in" *> expression
			Just e → return e
		return $ L bs e

	bindings = do
		(b,e) ← I.foldedLinesOf $ do
			b ← binding
			e ← optionMaybe $ sym "in" *> expression
			return (b,e)
		case e of
			Just _ → return ([b], e)
			Nothing → do
				m ← optionMaybe bindings
				case m of
					Nothing → return ([b], e)
					Just (bs, e) → return (b:bs, e)

	binding ∷ IndentParser (String,Λ)
	binding = flip label "binding" $ do
		funct  ← ident
		params ← many ident
		body   ← sym "=" *> expression
		return (funct, foldr Λ body params)

	ident ∷ IndentParser String
	ident = I.identifier lexer

	sym ∷ String → IndentParser String
	sym = P.try . I.symbol lexer