TransformeR-0.1.0.0: src/Parse.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module Parse where

import qualified Text.Parsec as P
import qualified Text.Parsec.Token as PT
import Text.Parsec.Language
import Text.Parsec.Expr
import Text.Parsec ((<?>))

import Control.Applicative
import Control.Monad.Identity (Identity)

import Syntax

type Parser = P.Parsec String ()

-- | parse olala, calls 'prog'
parse :: Parser a -> P.SourceName -> String -> Either P.ParseError a
parse = P.parse 

-- Parser

prog :: Parser Transformation
prog = do 
  P.string "transform" 
  whiteSpace
  (x, tau1) <- parens $ do x <- identifier
                           colon
                           tau1 <- recsig
                           return (x, tau1)
  tau2 <- colon *> recsig
  body <- braces expr
  return $ TRANS x tau1 tau2 body

expr :: Parser Expression
expr    = buildExpressionParser table term
         <?> "expression"

term :: Parser Expression
term    =  P.try (LIT <$> value)
       <|> P.try (MUTATE <$> identifier 
                         <*> brackets identifier 
                         <*> (P.string ":=" *> expr))
       <|> REC <$> (braces . commaSep) (do l <- identifier 
                                           whiteSpace
                                           P.char '=' 
                                           whiteSpace
                                           e <- expr
                                           return (l, e))
       <|> P.try (ASSIGN <$> (identifier <* P.string ":=") <*> expr)
       <|> P.try (OP <$> opr <*> (parens . commaSep) expr)
       <|> VAR <$> identifier
       <|> parens expr
       <?> "expression-term"

value :: Parser Value
value   =  NUM <$> float
       <|> CAT <$> stringLiteral
       <|> MAP <$> (braces . commaSep) (do l <- identifier 
                                           whiteSpace
                                           P.char '=' 
                                           whiteSpace
                                           v <- value 
                                           return (l, v))
       <?> "value"

opr :: Parser OPR
opr   =  SUM <$ P.char '+'
     <|> CONCAT <$ P.char '*'
     <?> "operator"

table :: OperatorTable String u Identity Expression
table = [ [Postfix (do {f <- brackets identifier; return (\e -> PROJ e f)})]
        , [binary semi SEQ AssocRight] ]

binary :: P.ParsecT s u m a1 -> (a -> a -> a) -> Assoc -> Operator s u m a
binary op fun asc = Infix (do{ op ; return fun }) asc

postfix :: P.ParsecT s u m a1 -> (a -> a) -> Operator s u m a
postfix op fun     = Postfix (do{ op; return fun })

recsig :: Parser Sig
recsig = Sig <$> (braces . commaSep $ do l <- identifier
                                         colon
                                         sig <- tysig
                                         return (l, sig))
  

tysig :: Parser Descriptor
tysig = (uncurry INTERVAL) <$> (P.char 'N' *> brackets (do lb <- float
                                                           comma
                                                           ub <- float
                                                           return (lb, ub)))
     <|> SET <$> (P.char 'C' *> (brackets . commaSep) stringLiteral)
     <?> "type signature"

-- Lexer

transformeRDef :: LanguageDef st
transformeRDef = emptyDef { PT.commentLine = "#"}

PT.TokenParser {..} = PT.makeTokenParser transformeRDef