diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,2 +1,2 @@ -David Castro Pérez -Henrique Ferreiro García +David Castro Pérez +Henrique Ferreiro García diff --git a/CoreErlang.cabal b/CoreErlang.cabal --- a/CoreErlang.cabal +++ b/CoreErlang.cabal @@ -1,35 +1,35 @@ -name: CoreErlang -version: 0.0.3 -copyright: 2008, David Castro Pérez, Henrique Ferreiro García -license: BSD3 -license-file: LICENSE -author: David Castro Pérez - Henrique Ferreiro García -maintainer: - Alex Kropivny -homepage: http://github.com/amtal/CoreErlang -category: Language -synopsis: Manipulating Core Erlang source code -description: - Facilities for manipulating Core Erlang source code: - an abstract syntax, parser and pretty-printer. -build-type: Simple -cabal-version: >= 1.6 - -extra-source-files: - AUTHORS LICENSE - -library - exposed-modules: - Language.CoreErlang.Parser, - Language.CoreErlang.Pretty, - Language.CoreErlang.Syntax - build-depends: - base >=4.8 && <4.9, - pretty >=1.1 && <1.2, - parsec >=3.1 && <3.2 - other-extensions: DeriveDataTypeable - -source-repository head - type: git - location: https://github.com/amtal/CoreErlang.git +name: CoreErlang +version: 0.0.4 +copyright: 2008, David Castro Pérez, Henrique Ferreiro García +license: BSD3 +license-file: LICENSE +author: David Castro Pérez + Henrique Ferreiro García +maintainer: + Alex Kropivny +homepage: http://github.com/amtal/CoreErlang +category: Language +synopsis: Manipulating Core Erlang source code +description: + Facilities for manipulating Core Erlang source code: + an abstract syntax, parser and pretty-printer. +build-type: Simple +cabal-version: >= 1.6 + +extra-source-files: + AUTHORS LICENSE + +library + exposed-modules: + Language.CoreErlang.Parser, + Language.CoreErlang.Pretty, + Language.CoreErlang.Syntax + build-depends: + base >=4.8 && <=4.11, + pretty >=1.1 && <1.2, + parsec >=3.1 && <3.2 + other-extensions: DeriveDataTypeable + +source-repository head + type: git + location: https://github.com/amtal/CoreErlang.git diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,38 +1,38 @@ -Copyright (c) 2008, David Castro Pérez - Henrique Ferreiro García - -This library is derived from code from the GHC project (libraries/haskell-src) -which is largely (c) The University of Glasgow, and distributable under -a BSD-style license. The full text of the license is reproduced below: - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. +Copyright (c) 2008, David Castro Pérez + Henrique Ferreiro García + +This library is derived from code from the GHC project (libraries/haskell-src) +which is largely (c) The University of Glasgow, and distributable under +a BSD-style license. The full text of the license is reproduced below: + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Language/CoreErlang/Parser.hs b/Language/CoreErlang/Parser.hs --- a/Language/CoreErlang/Parser.hs +++ b/Language/CoreErlang/Parser.hs @@ -1,386 +1,386 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.CoreErlang.Parser --- Copyright : (c) Henrique Ferreiro García 2008 --- (c) David Castro Pérez 2008 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Alex Kropivny --- Stability : experimental --- Portability : portable --- --- CoreErlang parser. --- - ------------------------------------------------------------------------------ - -module Language.CoreErlang.Parser - ( parseModule - , ParseError - ) where - -import Language.CoreErlang.Syntax - -import Control.Monad ( liftM ) -import Data.Char ( isControl, chr ) -import Numeric ( readOct ) - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import qualified Text.ParserCombinators.Parsec.Token as Token -import Text.ParserCombinators.Parsec.Token - ( makeTokenParser, TokenParser ) -import Text.ParserCombinators.Parsec.Language - --- Lexical definitions - -uppercase :: Parser Char -uppercase = upper - -lowercase :: Parser Char -lowercase = lower - -inputchar :: Parser Char -inputchar = noneOf "\n\r" - -control :: Parser Char -control = satisfy isControl - -namechar :: Parser Char -namechar = uppercase <|> lowercase <|> digit <|> oneOf "@_" - -escape :: Parser Char -escape = do char '\\' - s <- octal <|> ctrl <|> escapechar - return s - -octal :: Parser Char -octal = do chars <- tryOctal - let [(o, _)] = readOct chars - return (chr o) - -tryOctal :: Parser [Char] -tryOctal = choice [ try (count 3 octaldigit), - try (count 2 octaldigit), - try (count 1 octaldigit) ] - -octaldigit :: Parser Char -octaldigit = oneOf "01234567" - -ctrl :: Parser Char -ctrl = char '^' >> ctrlchar - -ctrlchar :: Parser Char -ctrlchar = satisfy (`elem` ['\x0040'..'\x005f']) - -escapechar = oneOf "bdefnrstv\"\'\\" - --- Terminals - -integer :: Parser Integer -integer = do i <- positive <|> negative <|> decimal - whiteSpace -- TODO: buff - return $ i - -positive :: Parser Integer -positive = do char '+' - p <- decimal - return p - -negative :: Parser Integer -negative = do char '-' - n <- decimal - return $ negate n - --- float :: Parser Double --- float = sign?digit+.digit+((E|e)sign?digit+)? - -atom :: Parser Atom -atom = do char '\'' --- ((inputchar except control and \ and ')|escape)* --- inputchar = noneOf "\n\r" - a <- many (noneOf "\n\r\\\'") - char '\'' - whiteSpace -- TODO: buff - return $ Atom a - -echar :: Parser Literal --- char = $((inputchar except control and space and \)|escape) -echar = do char '$' - c <- noneOf "\n\r\\ " - whiteSpace -- TODO: buff - return $ LChar c - -estring :: Parser Literal --- string = "((inputchar except control and \\ and \"")|escape)*" -estring = do char '"' - s <- many $ noneOf "\n\r\\\"" - char '"' - return $ LString s - -variable :: Parser Var --- variable = (uppercase | (_ namechar)) namechar* -variable = identifier - --- Non-terminals - -emodule :: Parser (Ann Module) -emodule = annotated amodule - -amodule :: Parser Module -amodule = do reserved "module" - name <- atom - funs <- exports - attrs <- attributes - fundefs <- many fundef - reserved "end" - return $ Module name funs attrs fundefs - -exports :: Parser [Function] -exports = brackets $ commaSep function - -attributes :: Parser [(Atom,Const)] -attributes = do reserved "attributes" - brackets (commaSep $ do a <- atom - symbol "=" - c <- constant - return (a,c)) - -constant :: Parser Const -constant = liftM CLit (try literal) <|> - liftM CTuple (tuple constant) <|> - liftM CList (elist constant) - -fundef :: Parser FunDef -fundef = do name <- annotated function - symbol "=" - body <- annotated lambda - return $ FunDef name body - -function :: Parser Function -function = do a <- atom - char '/' - i <- decimal - whiteSpace -- TODO: buff - return $ Function (a,i) - -literal :: Parser Literal -literal = try (liftM LFloat float) <|> liftM LInt integer <|> - liftM LAtom atom <|> nil <|> echar <|> estring - -nil :: Parser Literal -nil = brackets (return LNil) - -expression :: Parser Exps -expression = try (liftM Exps (annotated $ angles $ commaSep (annotated sexpression))) <|> - liftM Exp (annotated sexpression) - -sexpression :: Parser Exp -sexpression = app <|> ecatch <|> ecase <|> elet <|> - liftM Fun (try function) {- because of atom -} <|> - lambda <|> letrec <|> liftM Binary (ebinary expression) <|> - liftM List (try $ elist expression) {- because of nil -} <|> - liftM Lit literal <|> modcall <|> op <|> receive <|> - eseq <|> etry <|> liftM Tuple (tuple expression) <|> - liftM Var variable - -app :: Parser Exp -app = do reserved "apply" - e1 <- expression - eN <- parens $ commaSep expression - return $ App e1 eN - -ecatch :: Parser Exp -ecatch = do reserved "catch" - e <- expression - return $ Catch e - -ebinary :: Parser a -> Parser [BitString a] -ebinary p = do symbol "#" - bs <- braces (commaSep (bitstring p)) - symbol "#" - return bs - -bitstring :: Parser a -> Parser (BitString a) -bitstring p = do symbol "#" - e0 <- angles p - es <- parens (commaSep expression) - return $ BitString e0 es - -ecase :: Parser Exp -ecase = do reserved "case" - exp <- expression - reserved "of" - alts <- many1 (annotated clause) - reserved "end" - return $ Case exp alts - -clause :: Parser Alt -clause = do pat <- patterns - g <- guard - symbol "->" - exp <- expression - return $ Alt pat g exp - -patterns :: Parser Pats -patterns = liftM Pat pattern <|> - liftM Pats (angles $ commaSep pattern) - -pattern :: Parser Pat -pattern = liftM PAlias (try alias) {- because of variable -} <|> liftM PVar variable <|> - liftM PLit (try literal) {- because of nil -} <|> liftM PTuple (tuple pattern) <|> - liftM PList (elist pattern) <|> liftM PBinary (ebinary pattern) - -alias :: Parser Alias -alias = do v <- variable - symbol "=" - p <- pattern - return $ Alias v p - -guard :: Parser Guard -guard = do reserved "when" - e <- expression - return $ Guard e - -elet :: Parser Exp -elet = do reserved "let" - vars <- variables - symbol "=" - e1 <- expression - symbol "in" - e2 <- expression - return $ Let (vars,e1) e2 - -variables :: Parser [Var] -variables = do { v <- variable; return [v]} <|> (angles $ commaSep variable) - -lambda :: Parser Exp -lambda = do reserved "fun" - vars <- parens $ commaSep variable - symbol "->" - expr <- expression - return $ Lambda vars expr - -letrec :: Parser Exp -letrec = do reserved "letrec" - defs <- many fundef - reserved "in" - e <- expression - return $ LetRec defs e - -elist :: Parser a -> Parser (List a) -elist a = brackets $ list a - -list :: Parser a -> Parser (List a) -list elem = do elems <- commaSep1 elem - option (L elems) (do symbol "|" - t <- elem - return $ LL elems t) - -modcall :: Parser Exp -modcall = do reserved "call" - e1 <- expression - symbol ":" - e2 <- expression - eN <- parens $ commaSep expression - return $ ModCall (e1, e2) eN - -op :: Parser Exp -op = do reserved "primop" - a <- atom - e <- parens $ commaSep expression - return $ Op a e - -receive :: Parser Exp -receive = do reserved "receive" - alts <- many $ annotated clause - to <- timeout - return $ Rec alts to - -timeout :: Parser TimeOut -timeout = do reserved "after" - e1 <- expression - symbol "->" - e2 <- expression - return $ TimeOut e1 e2 - -eseq :: Parser Exp -eseq = do reserved "do" - e1 <- expression - e2 <- expression - return $ Seq e1 e2 - -etry :: Parser Exp -etry = do reserved "try" - e1 <- expression - reserved "of" - v1 <- variables - symbol "->" - e2 <- expression - reserved "catch" - v2 <- variables - symbol "->" - e3 <- expression - return $ Try e1 (v1,e1) (v2,e2) - -tuple :: Parser a -> Parser [a] -tuple elem = braces $ commaSep elem - -annotation :: Parser [Const] -annotation = do symbol "-|" - cs <- brackets $ many constant - return $ cs - -annotated :: Parser a -> Parser (Ann a) -annotated p = parens (do e <- p - cs <- annotation - return $ Ann e cs) - <|> - do e <- p - return $ Constr e - -lexer :: TokenParser () -lexer = makeTokenParser - (emptyDef { - -- commentStart = "", - -- commentEnd = "", - commentLine = "%", - -- nestedComments = True, - identStart = upper <|> char '_', - identLetter = namechar - -- opStart, - -- opLetter, - -- reservedNames, - -- reservedOpNames, - -- caseSensitive = True, - }) - -angles = Token.angles lexer -braces = Token.braces lexer -brackets = Token.brackets lexer -commaSep = Token.commaSep lexer -commaSep1 = Token.commaSep1 lexer -decimal = Token.decimal lexer -float = Token.float lexer -identifier = Token.identifier lexer -natural = Token.natural lexer -parens = Token.parens lexer -reserved = Token.reserved lexer -reservedOp = Token.reservedOp lexer -symbol = Token.symbol lexer -whiteSpace = Token.whiteSpace lexer - -runLex :: Show a => Parser a -> String -> IO () -runLex p file = do input <- readFile file - parseTest (do whiteSpace - x <- p - eof - return x) input - return () - --- | Parse of a string, which should contain a complete CoreErlang module -parseModule :: String -> Either ParseError (Ann Module) -parseModule input = parse (do whiteSpace - x <- emodule - eof - return x) "" input +----------------------------------------------------------------------------- +-- | +-- Module : Language.CoreErlang.Parser +-- Copyright : (c) Henrique Ferreiro García 2008 +-- (c) David Castro Pérez 2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Alex Kropivny +-- Stability : experimental +-- Portability : portable +-- +-- CoreErlang parser. +-- + +----------------------------------------------------------------------------- + +module Language.CoreErlang.Parser + ( parseModule + , ParseError + ) where + +import Language.CoreErlang.Syntax + +import Control.Monad ( liftM ) +import Data.Char ( isControl, chr ) +import Numeric ( readOct ) + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import qualified Text.ParserCombinators.Parsec.Token as Token +import Text.ParserCombinators.Parsec.Token + ( makeTokenParser, TokenParser ) +import Text.ParserCombinators.Parsec.Language + +-- Lexical definitions + +uppercase :: Parser Char +uppercase = upper + +lowercase :: Parser Char +lowercase = lower + +inputchar :: Parser Char +inputchar = noneOf "\n\r" + +control :: Parser Char +control = satisfy isControl + +namechar :: Parser Char +namechar = uppercase <|> lowercase <|> digit <|> oneOf "@_" + +escape :: Parser Char +escape = do char '\\' + s <- octal <|> ctrl <|> escapechar + return s + +octal :: Parser Char +octal = do chars <- tryOctal + let [(o, _)] = readOct chars + return (chr o) + +tryOctal :: Parser [Char] +tryOctal = choice [ try (count 3 octaldigit), + try (count 2 octaldigit), + try (count 1 octaldigit) ] + +octaldigit :: Parser Char +octaldigit = oneOf "01234567" + +ctrl :: Parser Char +ctrl = char '^' >> ctrlchar + +ctrlchar :: Parser Char +ctrlchar = satisfy (`elem` ['\x0040'..'\x005f']) + +escapechar = oneOf "bdefnrstv\"\'\\" + +-- Terminals + +integer :: Parser Integer +integer = do i <- positive <|> negative <|> decimal + whiteSpace -- TODO: buff + return $ i + +positive :: Parser Integer +positive = do char '+' + p <- decimal + return p + +negative :: Parser Integer +negative = do char '-' + n <- decimal + return $ negate n + +-- float :: Parser Double +-- float = sign?digit+.digit+((E|e)sign?digit+)? + +atom :: Parser Atom +atom = do char '\'' +-- ((inputchar except control and \ and ')|escape)* +-- inputchar = noneOf "\n\r" + a <- many (noneOf "\n\r\\\'") + char '\'' + whiteSpace -- TODO: buff + return $ Atom a + +echar :: Parser Literal +-- char = $((inputchar except control and space and \)|escape) +echar = do char '$' + c <- noneOf "\n\r\\ " + whiteSpace -- TODO: buff + return $ LChar c + +estring :: Parser Literal +-- string = "((inputchar except control and \\ and \"")|escape)*" +estring = do char '"' + s <- many $ noneOf "\n\r\\\"" + char '"' + return $ LString s + +variable :: Parser Var +-- variable = (uppercase | (_ namechar)) namechar* +variable = identifier + +-- Non-terminals + +emodule :: Parser (Ann Module) +emodule = annotated amodule + +amodule :: Parser Module +amodule = do reserved "module" + name <- atom + funs <- exports + attrs <- attributes + fundefs <- many fundef + reserved "end" + return $ Module name funs attrs fundefs + +exports :: Parser [Function] +exports = brackets $ commaSep function + +attributes :: Parser [(Atom,Const)] +attributes = do reserved "attributes" + brackets (commaSep $ do a <- atom + symbol "=" + c <- constant + return (a,c)) + +constant :: Parser Const +constant = liftM CLit (try literal) <|> + liftM CTuple (tuple constant) <|> + liftM CList (elist constant) + +fundef :: Parser FunDef +fundef = do name <- annotated function + symbol "=" + body <- annotated lambda + return $ FunDef name body + +function :: Parser Function +function = do a <- atom + char '/' + i <- decimal + whiteSpace -- TODO: buff + return $ Function (a,i) + +literal :: Parser Literal +literal = try (liftM LFloat float) <|> liftM LInt integer <|> + liftM LAtom atom <|> nil <|> echar <|> estring + +nil :: Parser Literal +nil = brackets (return LNil) + +expression :: Parser Exps +expression = try (liftM Exps (annotated $ angles $ commaSep (annotated sexpression))) <|> + liftM Exp (annotated sexpression) + +sexpression :: Parser Exp +sexpression = app <|> ecatch <|> ecase <|> elet <|> + liftM Fun (try function) {- because of atom -} <|> + lambda <|> letrec <|> liftM Binary (ebinary expression) <|> + liftM List (try $ elist expression) {- because of nil -} <|> + liftM Lit literal <|> modcall <|> op <|> receive <|> + eseq <|> etry <|> liftM Tuple (tuple expression) <|> + liftM Var variable + +app :: Parser Exp +app = do reserved "apply" + e1 <- expression + eN <- parens $ commaSep expression + return $ App e1 eN + +ecatch :: Parser Exp +ecatch = do reserved "catch" + e <- expression + return $ Catch e + +ebinary :: Parser a -> Parser [BitString a] +ebinary p = do symbol "#" + bs <- braces (commaSep (bitstring p)) + symbol "#" + return bs + +bitstring :: Parser a -> Parser (BitString a) +bitstring p = do symbol "#" + e0 <- angles p + es <- parens (commaSep expression) + return $ BitString e0 es + +ecase :: Parser Exp +ecase = do reserved "case" + exp <- expression + reserved "of" + alts <- many1 (annotated clause) + reserved "end" + return $ Case exp alts + +clause :: Parser Alt +clause = do pat <- patterns + g <- guard + symbol "->" + exp <- expression + return $ Alt pat g exp + +patterns :: Parser Pats +patterns = liftM Pat pattern <|> + liftM Pats (angles $ commaSep pattern) + +pattern :: Parser Pat +pattern = liftM PAlias (try alias) {- because of variable -} <|> liftM PVar variable <|> + liftM PLit (try literal) {- because of nil -} <|> liftM PTuple (tuple pattern) <|> + liftM PList (elist pattern) <|> liftM PBinary (ebinary pattern) + +alias :: Parser Alias +alias = do v <- variable + symbol "=" + p <- pattern + return $ Alias v p + +guard :: Parser Guard +guard = do reserved "when" + e <- expression + return $ Guard e + +elet :: Parser Exp +elet = do reserved "let" + vars <- variables + symbol "=" + e1 <- expression + symbol "in" + e2 <- expression + return $ Let (vars,e1) e2 + +variables :: Parser [Var] +variables = do { v <- variable; return [v]} <|> (angles $ commaSep variable) + +lambda :: Parser Exp +lambda = do reserved "fun" + vars <- parens $ commaSep variable + symbol "->" + expr <- expression + return $ Lambda vars expr + +letrec :: Parser Exp +letrec = do reserved "letrec" + defs <- many fundef + reserved "in" + e <- expression + return $ LetRec defs e + +elist :: Parser a -> Parser (List a) +elist a = brackets $ list a + +list :: Parser a -> Parser (List a) +list elem = do elems <- commaSep1 elem + option (L elems) (do symbol "|" + t <- elem + return $ LL elems t) + +modcall :: Parser Exp +modcall = do reserved "call" + e1 <- expression + symbol ":" + e2 <- expression + eN <- parens $ commaSep expression + return $ ModCall (e1, e2) eN + +op :: Parser Exp +op = do reserved "primop" + a <- atom + e <- parens $ commaSep expression + return $ Op a e + +receive :: Parser Exp +receive = do reserved "receive" + alts <- many $ annotated clause + to <- timeout + return $ Rec alts to + +timeout :: Parser TimeOut +timeout = do reserved "after" + e1 <- expression + symbol "->" + e2 <- expression + return $ TimeOut e1 e2 + +eseq :: Parser Exp +eseq = do reserved "do" + e1 <- expression + e2 <- expression + return $ Seq e1 e2 + +etry :: Parser Exp +etry = do reserved "try" + e1 <- expression + reserved "of" + v1 <- variables + symbol "->" + e2 <- expression + reserved "catch" + v2 <- variables + symbol "->" + e3 <- expression + return $ Try e1 (v1,e1) (v2,e2) + +tuple :: Parser a -> Parser [a] +tuple elem = braces $ commaSep elem + +annotation :: Parser [Const] +annotation = do symbol "-|" + cs <- brackets $ many constant + return $ cs + +annotated :: Parser a -> Parser (Ann a) +annotated p = parens (do e <- p + cs <- annotation + return $ Ann e cs) + <|> + do e <- p + return $ Constr e + +lexer :: TokenParser () +lexer = makeTokenParser + (emptyDef { + -- commentStart = "", + -- commentEnd = "", + commentLine = "%", + -- nestedComments = True, + identStart = upper <|> char '_', + identLetter = namechar + -- opStart, + -- opLetter, + -- reservedNames, + -- reservedOpNames, + -- caseSensitive = True, + }) + +angles = Token.angles lexer +braces = Token.braces lexer +brackets = Token.brackets lexer +commaSep = Token.commaSep lexer +commaSep1 = Token.commaSep1 lexer +decimal = Token.decimal lexer +float = Token.float lexer +identifier = Token.identifier lexer +natural = Token.natural lexer +parens = Token.parens lexer +reserved = Token.reserved lexer +reservedOp = Token.reservedOp lexer +symbol = Token.symbol lexer +whiteSpace = Token.whiteSpace lexer + +runLex :: Show a => Parser a -> String -> IO () +runLex p file = do input <- readFile file + parseTest (do whiteSpace + x <- p + eof + return x) input + return () + +-- | Parse of a string, which should contain a complete CoreErlang module +parseModule :: String -> Either ParseError (Ann Module) +parseModule input = parse (do whiteSpace + x <- emodule + eof + return x) "" input diff --git a/Language/CoreErlang/Pretty.hs b/Language/CoreErlang/Pretty.hs --- a/Language/CoreErlang/Pretty.hs +++ b/Language/CoreErlang/Pretty.hs @@ -1,424 +1,424 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.CoreErlang.Pretty --- Copyright : (c) Henrique Ferreiro García 2008 --- (c) David Castro Pérez 2008 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Alex Kropivny --- Stability : experimental --- Portability : portable --- --- Pretty printer for CoreErlang. --- ------------------------------------------------------------------------------ - -module Language.CoreErlang.Pretty ( - -- * Pretty printing - Pretty, - prettyPrintStyleMode, prettyPrintWithMode, prettyPrint, - -- * Pretty-printing styles (from -- "Text.PrettyPrint.HughesPJ") - P.Style(..), P.style, P.Mode(..), - -- * CoreErlang formatting modes - PPMode(..), Indent, PPLayout(..), defaultMode) where - -import Language.CoreErlang.Syntax - -import qualified Text.PrettyPrint as P - -infixl 5 $$$ - -------------------------------------------------------------------------------- - --- | Varieties of layout we can use. -data PPLayout = PPDefault -- ^ classical layout - | PPNoLayout -- ^ everything on a single line - deriving Eq - -type Indent = Int - --- | Pretty-printing parameters. -data PPMode = PPMode { - altIndent :: Indent, -- ^ indentation of the alternatives - -- in a @case@ expression - caseIndent :: Indent, -- ^ indentation of the declarations - -- in a @case@ expression - fundefIndent :: Indent, -- ^ indentation of the declarations - -- in a function definition - lambdaIndent :: Indent, -- ^ indentation of the declarations - -- in a @lambda@ expression - letIndent :: Indent, -- ^ indentation of the declarations - -- in a @let@ expression - letrecIndent :: Indent, -- ^ indentation of the declarations - -- in a @letrec@ expression - onsideIndent :: Indent, -- ^ indentation added for continuation - -- lines that would otherwise be offside - layout :: PPLayout -- ^ Pretty-printing style to use - } - --- | The default mode: pretty-print using sensible defaults. -defaultMode :: PPMode -defaultMode = PPMode { - altIndent = 4, - caseIndent = 4, - fundefIndent = 4, - lambdaIndent = 4, - letIndent = 4, - letrecIndent = 4, - onsideIndent = 4, - layout = PPDefault - } - --- | Pretty printing monad -newtype DocM s a = DocM (s -> a) - -instance Functor (DocM s) where - fmap f xs = do x <- xs; return (f x) - -instance Applicative (DocM s) where - pure = return - (<*>) m1 m2 = do x1 <- m1; x2 <- m2; return (x1 x2) - -instance Monad (DocM s) where - (>>=) = thenDocM - (>>) = then_DocM - return = retDocM - -{-# INLINE thenDocM #-} -{-# INLINE then_DocM #-} -{-# INLINE retDocM #-} -{-# INLINE unDocM #-} -{-# INLINE getPPEnv #-} - -thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b -thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s) - -then_DocM :: DocM s a -> DocM s b -> DocM s b -then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s) - -retDocM :: a -> DocM s a -retDocM a = DocM (\_s -> a) - -unDocM :: DocM s a -> (s -> a) -unDocM (DocM f) = f - --- all this extra stuff, just for this one function. -getPPEnv :: DocM s s -getPPEnv = DocM id - --- | The document type produced by these pretty printers uses a 'PPMode' --- environment. -type Doc = DocM PPMode P.Doc - --- | Things that can be pretty-printed, including all the syntactic objects --- in "Language.CoreErlang.Syntax". -class Pretty a where - -- | Pretty-print something in isolation. - pretty :: a -> Doc - -- | Pretty-print something in a precedence context. - prettyPrec :: Int -> a -> Doc - pretty = prettyPrec 0 - prettyPrec _ = pretty - --- The pretty printing combinators - -empty :: Doc -empty = return P.empty - -nest :: Int -> Doc -> Doc -nest i m = m >>= return . P.nest i - --- Literals -text, ptext :: String -> Doc -text = return . P.text -ptext = return . P.text - -char :: Char -> Doc -char = return . P.char - -int :: Int -> Doc -int = return . P.int - -integer :: Integer -> Doc -integer = return . P.integer - -float :: Float -> Doc -float = return . P.float - -double :: Double -> Doc -double = return . P.double - --- Simple Combining Forms -parens, brackets, braces, quotes, doubleQuotes :: Doc -> Doc -parens d = d >>= return . P.parens -brackets d = d >>= return . P.brackets -braces d = d >>= return . P.braces -quotes d = d >>= return . P.quotes -doubleQuotes d = d >>= return . P.doubleQuotes - -parensIf :: Bool -> Doc -> Doc -parensIf True = parens -parensIf False = id - --- Constants -semi, comma, colon, space, equals :: Doc -semi = return P.semi -comma = return P.comma -colon = return P.colon -space = return P.space -equals = return P.equals - -lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc -lparen = return P.lparen -rparen = return P.rparen -lbrack = return P.lbrack -rbrack = return P.rbrack -lbrace = return P.lbrace -rbrace = return P.rbrace - --- Combinators - -(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc -aM <> bM = do { a <- aM; b <- bM; return $ a P.<> b} -aM <+> bM = do { a <- aM; b <- bM; return $ a P.<+> b} -aM $$ bM = do { a <- aM; b <- bM; return $ a P.$$ b} -aM $+$ bM = do { a <- aM; b <- bM; return $ a P.$+$ b} - -hcat, hsep, vcat, sep, cat, fsep, fcat :: [Doc] -> Doc -hcat dl = sequence dl >>= return . P.hcat -hsep dl = sequence dl >>= return . P.hsep -vcat dl = sequence dl >>= return . P.vcat -sep dl = sequence dl >>= return . P.sep -cat dl = sequence dl >>= return . P.cat -fsep dl = sequence dl >>= return . P.fsep -fcat dl = sequence dl >>= return . P.fcat - --- Some More - -hang :: Doc -> Int -> Doc -> Doc -hang dM i rM = do { d <- dM; r <- rM; return $ P.hang d i r } - --- Yuk, had to cut-n-paste this one from Pretty.hs -punctuate :: Doc -> [Doc] -> [Doc] -punctuate _ [] = [] -punctuate p (d1:ds) = go d1 ds - where - go d [] = [d] - go d (e:es) = (d <> p) : go e es - --- | render the document with a given style and mode. -renderStyleMode :: P.Style -> PPMode -> Doc -> String -renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode - --- | render the document with a given mode. -renderWithMode :: PPMode -> Doc -> String -renderWithMode = renderStyleMode P.style - --- | render the document with defaultMode -render :: Doc -> String -render = renderWithMode defaultMode - --- | pretty-print with a given style and mode. -prettyPrintStyleMode :: Pretty a => P.Style -> PPMode -> a -> String -prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty - --- | pretty-print with the default style and a given mode. -prettyPrintWithMode :: Pretty a => PPMode -> a -> String -prettyPrintWithMode = prettyPrintStyleMode P.style - --- | pretty-print with the default style and 'defaultMode'. -prettyPrint :: Pretty a => a -> String -prettyPrint = prettyPrintWithMode defaultMode - -fullRenderWithMode :: PPMode -> P.Mode -> Int -> Float -> - (P.TextDetails -> a -> a) -> a -> Doc -> a -fullRenderWithMode ppMode m i f fn e mD = - P.fullRender m i f fn e $ (unDocM mD) ppMode - -fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) - -> a -> Doc -> a -fullRender = fullRenderWithMode defaultMode - -------------------------- Pretty-Print a Module -------------------- -instance Pretty Module where - pretty (Module m exports attrs fundefs) = - topLevel (ppModuleHeader m exports attrs) - (map pretty fundefs) - --------------------------- Module Header ------------------------------ -ppModuleHeader :: Atom -> [Function] -> [(Atom,Const)] -> Doc -ppModuleHeader m exports attrs = myFsep [ - text "module" <+> pretty m <+> (bracketList $ map pretty exports), - text "attributes" <+> bracketList (map ppAssign attrs)] - -instance Pretty Function where - pretty (Function (name,arity)) = - pretty name <> char '/' <> integer arity - -instance Pretty Const where - pretty (CLit l) = pretty l - pretty (CTuple l) = ppTuple l - pretty (CList l) = pretty l - -------------------------- Declarations ------------------------------ -instance Pretty FunDef where - pretty (FunDef function exp) = (pretty function <+> char '=') $$$ - ppBody fundefIndent [pretty exp] - -------------------------- Expressions ------------------------- -instance Pretty Literal where - pretty (LChar c) = char c - pretty (LString s) = text (show s) - pretty (LInt i) = integer i - pretty (LFloat f) = double f - pretty (LAtom a) = pretty a - pretty LNil = bracketList [empty] - -instance Pretty Atom where - pretty (Atom a) = char '\'' <> text a <> char '\'' - -instance Pretty Exps where - pretty (Exp e) = pretty e - pretty (Exps (Constr e)) = angleList (map pretty e) - pretty (Exps (Ann e cs)) = parens (angleList (map pretty e) - $$$ ppAnn cs) - -instance Pretty Exp where - pretty (Var v) = text v - pretty (Lit l) = pretty l - pretty (Fun f) = pretty f - pretty (App e exps) = text "apply" <+> - pretty e <> parenList (map pretty exps) - pretty (ModCall (e1,e2) exps) = sep [text "call" <+> - pretty e1 <> char ':' <> pretty e2, - parenList (map pretty exps)] - pretty (Lambda vars e) = sep [text "fun" <> parenList (map text vars) <+> text "->", - ppBody lambdaIndent [pretty e]] - pretty (Seq e1 e2) = sep [text "do", pretty e1, pretty e2] - pretty (Let (vars,e1) e2) = text "let" <+> - angleList (map text vars) <+> - char '=' <+> pretty e1 - $$$ text "in" <+> pretty e2 - pretty (LetRec fundefs e) = sep [text "letrec" <+> - ppBody letrecIndent (map pretty fundefs), - text "in", pretty e] - pretty (Case e alts) = sep [text "case", pretty e, text "of"] - $$$ ppBody caseIndent (map pretty alts) - $$$ text "end" - pretty (Tuple exps) = braceList $ map pretty exps - pretty (List l) = pretty l - pretty (Op a exps) = text "primop" <+> pretty a <> parenList (map pretty exps) - pretty (Binary bs) = char '#' <> braceList (map pretty bs) <> char '#' - pretty (Try e (vars1,exps1) (vars2,exps2)) = text "try" - $$$ ppBody caseIndent [pretty e] - $$$ text "of" <+> angleList (map text vars1) <+> text "->" - $$$ ppBody altIndent [pretty exps1] - $$$ text "catch" <+> angleList (map text vars2) <+> text "->" - $$$ ppBody altIndent [pretty exps2] - pretty (Rec alts tout) = text "receive" - $$$ ppBody caseIndent (map pretty alts) - $$$ text "after" - $$$ ppBody caseIndent [pretty tout] - pretty (Catch e) = sep [text "catch", pretty e] - -instance Pretty a => Pretty (List a) where - pretty (L l) = bracketList $ map pretty l - pretty (LL h t) = brackets . hcat $ punctuate comma (map pretty h) ++ - [char '|' <> pretty t] -instance Pretty Alt where - pretty (Alt pats guard exps) = - myFsep [pretty pats, pretty guard <+> text "->"] - $$$ ppBody altIndent [pretty exps] - -instance Pretty Pats where - pretty (Pat p) = pretty p - pretty (Pats p) = angleList (map pretty p) - -instance Pretty Pat where - pretty (PVar v) = text v - pretty (PLit l) = pretty l - pretty (PTuple p) = braceList $ map pretty p - pretty (PList l) = pretty l - pretty (PBinary bs) = char '#' <> braceList (map pretty bs) <> char '#' - pretty (PAlias a) = pretty a - -instance Pretty Alias where - pretty (Alias v p) = ppAssign (Var v,p) -- FIXME: hack! - -instance Pretty Guard where - pretty (Guard e) = text "when" <+> pretty e - -instance Pretty TimeOut where - pretty (TimeOut e1 e2) = pretty e1 <+> text "->" - $$$ ppBody altIndent [pretty e2] - -instance Pretty a => Pretty (BitString a) where - pretty (BitString e es) = text "#<" <> pretty e <> char '>' <> parenList (map pretty es) - ------------------------ Annotations ------------------------ -instance Pretty a => Pretty (Ann a) where - pretty (Constr a) = pretty a - pretty (Ann a cs) = parens (pretty a $$$ ppAnn cs) - - -------------------------- pp utils ------------------------- -angles :: Doc -> Doc -angles p = char '<' <> p <> char '>' - -angleList :: [Doc] -> Doc -angleList = angles . myFsepSimple . punctuate comma - -braceList :: [Doc] -> Doc -braceList = braces . myFsepSimple . punctuate comma - -bracketList :: [Doc] -> Doc -bracketList = brackets . myFsepSimple . punctuate comma - -parenList :: [Doc] -> Doc -parenList = parens . myFsepSimple . punctuate comma - --- | Monadic PP Combinators -- these examine the env -topLevel :: Doc -> [Doc] -> Doc -topLevel header dl = do e <- fmap layout getPPEnv - let s = case e of - PPDefault -> header $$ vcat dl - PPNoLayout -> header <+> hsep dl - s $$$ text "end" - -ppAssign :: (Pretty a,Pretty b) => (a,b) -> Doc -ppAssign (a,b) = pretty a <+> char '=' <+> pretty b - -ppTuple :: Pretty a => [a] -> Doc -ppTuple t = braceList (map pretty t) - -ppBody :: (PPMode -> Int) -> [Doc] -> Doc -ppBody f dl = do e <- fmap layout getPPEnv - i <- fmap f getPPEnv - case e of - PPDefault -> nest i . vcat $ dl - _ -> hsep dl - -($$$) :: Doc -> Doc -> Doc -a $$$ b = layoutChoice (a $$) (a <+>) b - -myFsepSimple :: [Doc] -> Doc -myFsepSimple = layoutChoice fsep hsep - --- same, except that continuation lines are indented, --- which is necessary to avoid triggering the offside rule. -myFsep :: [Doc] -> Doc -myFsep = layoutChoice fsep' hsep - where fsep' [] = empty - fsep' (d:ds) = do - e <- getPPEnv - let n = onsideIndent e - nest n (fsep (nest (-n) d:ds)) - -layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc -layoutChoice a b dl = do e <- getPPEnv - if layout e == PPDefault - then a dl - else b dl - -ppAnn :: (Pretty a) => [a] -> Doc -ppAnn cs = text "-|" <+> bracketList (map pretty cs) +----------------------------------------------------------------------------- +-- | +-- Module : Language.CoreErlang.Pretty +-- Copyright : (c) Henrique Ferreiro García 2008 +-- (c) David Castro Pérez 2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Alex Kropivny +-- Stability : experimental +-- Portability : portable +-- +-- Pretty printer for CoreErlang. +-- +----------------------------------------------------------------------------- + +module Language.CoreErlang.Pretty ( + -- * Pretty printing + Pretty, + prettyPrintStyleMode, prettyPrintWithMode, prettyPrint, + -- * Pretty-printing styles (from -- "Text.PrettyPrint.HughesPJ") + P.Style(..), P.style, P.Mode(..), + -- * CoreErlang formatting modes + PPMode(..), Indent, PPLayout(..), defaultMode) where + +import Language.CoreErlang.Syntax + +import qualified Text.PrettyPrint as P + +infixl 5 $$$ + +------------------------------------------------------------------------------- + +-- | Varieties of layout we can use. +data PPLayout = PPDefault -- ^ classical layout + | PPNoLayout -- ^ everything on a single line + deriving Eq + +type Indent = Int + +-- | Pretty-printing parameters. +data PPMode = PPMode { + altIndent :: Indent, -- ^ indentation of the alternatives + -- in a @case@ expression + caseIndent :: Indent, -- ^ indentation of the declarations + -- in a @case@ expression + fundefIndent :: Indent, -- ^ indentation of the declarations + -- in a function definition + lambdaIndent :: Indent, -- ^ indentation of the declarations + -- in a @lambda@ expression + letIndent :: Indent, -- ^ indentation of the declarations + -- in a @let@ expression + letrecIndent :: Indent, -- ^ indentation of the declarations + -- in a @letrec@ expression + onsideIndent :: Indent, -- ^ indentation added for continuation + -- lines that would otherwise be offside + layout :: PPLayout -- ^ Pretty-printing style to use + } + +-- | The default mode: pretty-print using sensible defaults. +defaultMode :: PPMode +defaultMode = PPMode { + altIndent = 4, + caseIndent = 4, + fundefIndent = 4, + lambdaIndent = 4, + letIndent = 4, + letrecIndent = 4, + onsideIndent = 4, + layout = PPDefault + } + +-- | Pretty printing monad +newtype DocM s a = DocM (s -> a) + +instance Functor (DocM s) where + fmap f xs = do x <- xs; return (f x) + +instance Applicative (DocM s) where + pure = return + (<*>) m1 m2 = do x1 <- m1; x2 <- m2; return (x1 x2) + +instance Monad (DocM s) where + (>>=) = thenDocM + (>>) = then_DocM + return = retDocM + +{-# INLINE thenDocM #-} +{-# INLINE then_DocM #-} +{-# INLINE retDocM #-} +{-# INLINE unDocM #-} +{-# INLINE getPPEnv #-} + +thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b +thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s) + +then_DocM :: DocM s a -> DocM s b -> DocM s b +then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s) + +retDocM :: a -> DocM s a +retDocM a = DocM (\_s -> a) + +unDocM :: DocM s a -> (s -> a) +unDocM (DocM f) = f + +-- all this extra stuff, just for this one function. +getPPEnv :: DocM s s +getPPEnv = DocM id + +-- | The document type produced by these pretty printers uses a 'PPMode' +-- environment. +type Doc = DocM PPMode P.Doc + +-- | Things that can be pretty-printed, including all the syntactic objects +-- in "Language.CoreErlang.Syntax". +class Pretty a where + -- | Pretty-print something in isolation. + pretty :: a -> Doc + -- | Pretty-print something in a precedence context. + prettyPrec :: Int -> a -> Doc + pretty = prettyPrec 0 + prettyPrec _ = pretty + +-- The pretty printing combinators + +empty :: Doc +empty = return P.empty + +nest :: Int -> Doc -> Doc +nest i m = m >>= return . P.nest i + +-- Literals +text, ptext :: String -> Doc +text = return . P.text +ptext = return . P.text + +char :: Char -> Doc +char = return . P.char + +int :: Int -> Doc +int = return . P.int + +integer :: Integer -> Doc +integer = return . P.integer + +float :: Float -> Doc +float = return . P.float + +double :: Double -> Doc +double = return . P.double + +-- Simple Combining Forms +parens, brackets, braces, quotes, doubleQuotes :: Doc -> Doc +parens d = d >>= return . P.parens +brackets d = d >>= return . P.brackets +braces d = d >>= return . P.braces +quotes d = d >>= return . P.quotes +doubleQuotes d = d >>= return . P.doubleQuotes + +parensIf :: Bool -> Doc -> Doc +parensIf True = parens +parensIf False = id + +-- Constants +semi, comma, colon, space, equals :: Doc +semi = return P.semi +comma = return P.comma +colon = return P.colon +space = return P.space +equals = return P.equals + +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc +lparen = return P.lparen +rparen = return P.rparen +lbrack = return P.lbrack +rbrack = return P.rbrack +lbrace = return P.lbrace +rbrace = return P.rbrace + +-- Combinators + +(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc +aM <> bM = do { a <- aM; b <- bM; return $ a P.<> b} +aM <+> bM = do { a <- aM; b <- bM; return $ a P.<+> b} +aM $$ bM = do { a <- aM; b <- bM; return $ a P.$$ b} +aM $+$ bM = do { a <- aM; b <- bM; return $ a P.$+$ b} + +hcat, hsep, vcat, sep, cat, fsep, fcat :: [Doc] -> Doc +hcat dl = sequence dl >>= return . P.hcat +hsep dl = sequence dl >>= return . P.hsep +vcat dl = sequence dl >>= return . P.vcat +sep dl = sequence dl >>= return . P.sep +cat dl = sequence dl >>= return . P.cat +fsep dl = sequence dl >>= return . P.fsep +fcat dl = sequence dl >>= return . P.fcat + +-- Some More + +hang :: Doc -> Int -> Doc -> Doc +hang dM i rM = do { d <- dM; r <- rM; return $ P.hang d i r } + +-- Yuk, had to cut-n-paste this one from Pretty.hs +punctuate :: Doc -> [Doc] -> [Doc] +punctuate _ [] = [] +punctuate p (d1:ds) = go d1 ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +-- | render the document with a given style and mode. +renderStyleMode :: P.Style -> PPMode -> Doc -> String +renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode + +-- | render the document with a given mode. +renderWithMode :: PPMode -> Doc -> String +renderWithMode = renderStyleMode P.style + +-- | render the document with defaultMode +render :: Doc -> String +render = renderWithMode defaultMode + +-- | pretty-print with a given style and mode. +prettyPrintStyleMode :: Pretty a => P.Style -> PPMode -> a -> String +prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty + +-- | pretty-print with the default style and a given mode. +prettyPrintWithMode :: Pretty a => PPMode -> a -> String +prettyPrintWithMode = prettyPrintStyleMode P.style + +-- | pretty-print with the default style and 'defaultMode'. +prettyPrint :: Pretty a => a -> String +prettyPrint = prettyPrintWithMode defaultMode + +fullRenderWithMode :: PPMode -> P.Mode -> Int -> Float -> + (P.TextDetails -> a -> a) -> a -> Doc -> a +fullRenderWithMode ppMode m i f fn e mD = + P.fullRender m i f fn e $ (unDocM mD) ppMode + +fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) + -> a -> Doc -> a +fullRender = fullRenderWithMode defaultMode + +------------------------- Pretty-Print a Module -------------------- +instance Pretty Module where + pretty (Module m exports attrs fundefs) = + topLevel (ppModuleHeader m exports attrs) + (map pretty fundefs) + +-------------------------- Module Header ------------------------------ +ppModuleHeader :: Atom -> [Function] -> [(Atom,Const)] -> Doc +ppModuleHeader m exports attrs = myFsep [ + text "module" <+> pretty m <+> (bracketList $ map pretty exports), + text "attributes" <+> bracketList (map ppAssign attrs)] + +instance Pretty Function where + pretty (Function (name,arity)) = + pretty name <> char '/' <> integer arity + +instance Pretty Const where + pretty (CLit l) = pretty l + pretty (CTuple l) = ppTuple l + pretty (CList l) = pretty l + +------------------------- Declarations ------------------------------ +instance Pretty FunDef where + pretty (FunDef function exp) = (pretty function <+> char '=') $$$ + ppBody fundefIndent [pretty exp] + +------------------------- Expressions ------------------------- +instance Pretty Literal where + pretty (LChar c) = char c + pretty (LString s) = text (show s) + pretty (LInt i) = integer i + pretty (LFloat f) = double f + pretty (LAtom a) = pretty a + pretty LNil = bracketList [empty] + +instance Pretty Atom where + pretty (Atom a) = char '\'' <> text a <> char '\'' + +instance Pretty Exps where + pretty (Exp e) = pretty e + pretty (Exps (Constr e)) = angleList (map pretty e) + pretty (Exps (Ann e cs)) = parens (angleList (map pretty e) + $$$ ppAnn cs) + +instance Pretty Exp where + pretty (Var v) = text v + pretty (Lit l) = pretty l + pretty (Fun f) = pretty f + pretty (App e exps) = text "apply" <+> + pretty e <> parenList (map pretty exps) + pretty (ModCall (e1,e2) exps) = sep [text "call" <+> + pretty e1 <> char ':' <> pretty e2, + parenList (map pretty exps)] + pretty (Lambda vars e) = sep [text "fun" <> parenList (map text vars) <+> text "->", + ppBody lambdaIndent [pretty e]] + pretty (Seq e1 e2) = sep [text "do", pretty e1, pretty e2] + pretty (Let (vars,e1) e2) = text "let" <+> + angleList (map text vars) <+> + char '=' <+> pretty e1 + $$$ text "in" <+> pretty e2 + pretty (LetRec fundefs e) = sep [text "letrec" <+> + ppBody letrecIndent (map pretty fundefs), + text "in", pretty e] + pretty (Case e alts) = sep [text "case", pretty e, text "of"] + $$$ ppBody caseIndent (map pretty alts) + $$$ text "end" + pretty (Tuple exps) = braceList $ map pretty exps + pretty (List l) = pretty l + pretty (Op a exps) = text "primop" <+> pretty a <> parenList (map pretty exps) + pretty (Binary bs) = char '#' <> braceList (map pretty bs) <> char '#' + pretty (Try e (vars1,exps1) (vars2,exps2)) = text "try" + $$$ ppBody caseIndent [pretty e] + $$$ text "of" <+> angleList (map text vars1) <+> text "->" + $$$ ppBody altIndent [pretty exps1] + $$$ text "catch" <+> angleList (map text vars2) <+> text "->" + $$$ ppBody altIndent [pretty exps2] + pretty (Rec alts tout) = text "receive" + $$$ ppBody caseIndent (map pretty alts) + $$$ text "after" + $$$ ppBody caseIndent [pretty tout] + pretty (Catch e) = sep [text "catch", pretty e] + +instance Pretty a => Pretty (List a) where + pretty (L l) = bracketList $ map pretty l + pretty (LL h t) = brackets . hcat $ punctuate comma (map pretty h) ++ + [char '|' <> pretty t] +instance Pretty Alt where + pretty (Alt pats guard exps) = + myFsep [pretty pats, pretty guard <+> text "->"] + $$$ ppBody altIndent [pretty exps] + +instance Pretty Pats where + pretty (Pat p) = pretty p + pretty (Pats p) = angleList (map pretty p) + +instance Pretty Pat where + pretty (PVar v) = text v + pretty (PLit l) = pretty l + pretty (PTuple p) = braceList $ map pretty p + pretty (PList l) = pretty l + pretty (PBinary bs) = char '#' <> braceList (map pretty bs) <> char '#' + pretty (PAlias a) = pretty a + +instance Pretty Alias where + pretty (Alias v p) = ppAssign (Var v,p) -- FIXME: hack! + +instance Pretty Guard where + pretty (Guard e) = text "when" <+> pretty e + +instance Pretty TimeOut where + pretty (TimeOut e1 e2) = pretty e1 <+> text "->" + $$$ ppBody altIndent [pretty e2] + +instance Pretty a => Pretty (BitString a) where + pretty (BitString e es) = text "#<" <> pretty e <> char '>' <> parenList (map pretty es) + +----------------------- Annotations ------------------------ +instance Pretty a => Pretty (Ann a) where + pretty (Constr a) = pretty a + pretty (Ann a cs) = parens (pretty a $$$ ppAnn cs) + + +------------------------- pp utils ------------------------- +angles :: Doc -> Doc +angles p = char '<' <> p <> char '>' + +angleList :: [Doc] -> Doc +angleList = angles . myFsepSimple . punctuate comma + +braceList :: [Doc] -> Doc +braceList = braces . myFsepSimple . punctuate comma + +bracketList :: [Doc] -> Doc +bracketList = brackets . myFsepSimple . punctuate comma + +parenList :: [Doc] -> Doc +parenList = parens . myFsepSimple . punctuate comma + +-- | Monadic PP Combinators -- these examine the env +topLevel :: Doc -> [Doc] -> Doc +topLevel header dl = do e <- fmap layout getPPEnv + let s = case e of + PPDefault -> header $$ vcat dl + PPNoLayout -> header <+> hsep dl + s $$$ text "end" + +ppAssign :: (Pretty a,Pretty b) => (a,b) -> Doc +ppAssign (a,b) = pretty a <+> char '=' <+> pretty b + +ppTuple :: Pretty a => [a] -> Doc +ppTuple t = braceList (map pretty t) + +ppBody :: (PPMode -> Int) -> [Doc] -> Doc +ppBody f dl = do e <- fmap layout getPPEnv + i <- fmap f getPPEnv + case e of + PPDefault -> nest i . vcat $ dl + _ -> hsep dl + +($$$) :: Doc -> Doc -> Doc +a $$$ b = layoutChoice (a $$) (a <+>) b + +myFsepSimple :: [Doc] -> Doc +myFsepSimple = layoutChoice fsep hsep + +-- same, except that continuation lines are indented, +-- which is necessary to avoid triggering the offside rule. +myFsep :: [Doc] -> Doc +myFsep = layoutChoice fsep' hsep + where fsep' [] = empty + fsep' (d:ds) = do + e <- getPPEnv + let n = onsideIndent e + nest n (fsep (nest (-n) d:ds)) + +layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc +layoutChoice a b dl = do e <- getPPEnv + if layout e == PPDefault + then a dl + else b dl + +ppAnn :: (Pretty a) => [a] -> Doc +ppAnn cs = text "-|" <+> bracketList (map pretty cs) diff --git a/Language/CoreErlang/Syntax.hs b/Language/CoreErlang/Syntax.hs --- a/Language/CoreErlang/Syntax.hs +++ b/Language/CoreErlang/Syntax.hs @@ -1,157 +1,157 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.CoreErlang.Syntax --- Copyright : (c) Henrique Ferreiro García 2008 --- (c) David Castro Pérez 2008 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Alex Kropivny --- Stability : experimental --- Portability : portable --- --- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3. --- - ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable #-} - -module Language.CoreErlang.Syntax ( - -- * Modules - Module(..), - -- * Declarations - FunDef(..), - -- * Expressions - Exp(..), Exps(..), Alt(..), Guard(..), - List(..), TimeOut(..), BitString(..), Function(..), - -- * Patterns - Pats(..), Pat(..), Alias(..), - -- * Literals - Literal(..), Const(..), Atom(..), - -- * Variables - Var, - -- * Annotations - Ann(..), - ) where - -import Data.Data - --- | This type is used to represent variables -type Var = String - --- | This type is used to represent atoms -data Atom = Atom String - deriving (Eq,Ord,Show,Data,Typeable) - --- | This type is used to represent function names -data Function = Function (Atom,Integer) - deriving (Eq,Ord,Show,Data,Typeable) - --- | A CoreErlang source module. -data Module - = Module Atom [Function] [(Atom,Const)] [FunDef] - deriving (Eq,Ord,Show,Data,Typeable) - --- | This type is used to represent constants -data Const - = CLit Literal - | CTuple [Const] - | CList (List Const) - deriving (Eq,Ord,Show,Data,Typeable) - --- | This type is used to represent lambdas -data FunDef - = FunDef (Ann Function) (Ann Exp) - deriving (Eq,Ord,Show,Data,Typeable) - --- | /literal/. --- Values of this type hold the abstract value of the literal, not the --- precise string representation used. For example, @10@, @0o12@ and @0xa@ --- have the same representation. -data Literal - = LChar Char -- ^ character literal - | LString String -- ^ string literal - | LInt Integer -- ^ integer literal - | LFloat Double -- ^ floating point literal - | LAtom Atom -- ^ atom literal - | LNil -- ^ empty list - deriving (Eq,Ord,Show,Data,Typeable) - --- | CoreErlang expressions. -data Exps - = Exp (Ann Exp) -- ^ single expression - | Exps (Ann [Ann Exp]) -- ^ list of expressions - deriving (Eq,Ord,Show,Data,Typeable) - --- | CoreErlang expression. -data Exp - = Var Var -- ^ variable - | Lit Literal -- ^ literal constant - | Fun Function -- ^ function name - | App Exps [Exps] -- ^ application - | ModCall (Exps,Exps) [Exps] -- ^ module call - | Lambda [Var] Exps -- ^ lambda expression - | Seq Exps Exps -- ^ sequencing - | Let ([Var],Exps) Exps -- ^ local declaration - | LetRec [FunDef] Exps -- ^ letrec expression - | Case Exps [Ann Alt] -- ^ @case@ /exp/ @of@ /alts/ end - | Tuple [Exps] -- ^ tuple expression - | List (List Exps) -- ^ list expression - | Binary [BitString Exps] -- ^ binary expression - | Op Atom [Exps] -- ^ operator application - | Try Exps ([Var],Exps) ([Var],Exps) -- ^ try expression - | Rec [Ann Alt] TimeOut -- ^ receive expression - | Catch Exps -- ^ catch expression - deriving (Eq,Ord,Show,Data,Typeable) - --- | A bitstring. -data BitString a - = BitString a [Exps] - deriving (Eq,Ord,Show,Data,Typeable) - --- | A list of expressions -data List a - = L [a] - | LL [a] a - deriving (Eq,Ord,Show,Data,Typeable) - --- | An /alt/ in a @case@ expression -data Alt - = Alt Pats Guard Exps - deriving (Eq,Ord,Show,Data,Typeable) - -data Pats - = Pat Pat -- ^ single pattern - | Pats [Pat] -- ^ list of patterns - deriving (Eq,Ord,Show,Data,Typeable) - --- | A pattern, to be matched against a value. -data Pat - = PVar Var -- ^ variable - | PLit Literal -- ^ literal constant - | PTuple [Pat] -- ^ tuple pattern - | PList (List Pat) -- ^ list pattern - | PBinary [BitString Pat] -- ^ list of bitstring patterns - | PAlias Alias -- ^ alias pattern - deriving (Eq,Ord,Show,Data,Typeable) - --- | An alias, used in patterns -data Alias - = Alias Var Pat - deriving (Eq,Ord,Show,Data,Typeable) - --- | A guarded alternative @when@ /exp/ @->@ /exp/. --- The first expression will be Boolean-valued. -data Guard - = Guard Exps - deriving (Eq,Ord,Show,Data,Typeable) - --- | The timeout of a receive expression -data TimeOut - = TimeOut Exps Exps - deriving (Eq,Ord,Show,Data,Typeable) - --- | An annotation for modules, variables, ... -data Ann a - = Constr a -- ^ core erlang construct - | Ann a [Const] -- ^ core erlang annotated construct - deriving (Eq,Ord,Show,Data,Typeable) +----------------------------------------------------------------------------- +-- | +-- Module : Language.CoreErlang.Syntax +-- Copyright : (c) Henrique Ferreiro García 2008 +-- (c) David Castro Pérez 2008 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Alex Kropivny +-- Stability : experimental +-- Portability : portable +-- +-- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3. +-- + +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} + +module Language.CoreErlang.Syntax ( + -- * Modules + Module(..), + -- * Declarations + FunDef(..), + -- * Expressions + Exp(..), Exps(..), Alt(..), Guard(..), + List(..), TimeOut(..), BitString(..), Function(..), + -- * Patterns + Pats(..), Pat(..), Alias(..), + -- * Literals + Literal(..), Const(..), Atom(..), + -- * Variables + Var, + -- * Annotations + Ann(..), + ) where + +import Data.Data + +-- | This type is used to represent variables +type Var = String + +-- | This type is used to represent atoms +data Atom = Atom String + deriving (Eq,Ord,Show,Data,Typeable) + +-- | This type is used to represent function names +data Function = Function (Atom,Integer) + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A CoreErlang source module. +data Module + = Module Atom [Function] [(Atom,Const)] [FunDef] + deriving (Eq,Ord,Show,Data,Typeable) + +-- | This type is used to represent constants +data Const + = CLit Literal + | CTuple [Const] + | CList (List Const) + deriving (Eq,Ord,Show,Data,Typeable) + +-- | This type is used to represent lambdas +data FunDef + = FunDef (Ann Function) (Ann Exp) + deriving (Eq,Ord,Show,Data,Typeable) + +-- | /literal/. +-- Values of this type hold the abstract value of the literal, not the +-- precise string representation used. For example, @10@, @0o12@ and @0xa@ +-- have the same representation. +data Literal + = LChar Char -- ^ character literal + | LString String -- ^ string literal + | LInt Integer -- ^ integer literal + | LFloat Double -- ^ floating point literal + | LAtom Atom -- ^ atom literal + | LNil -- ^ empty list + deriving (Eq,Ord,Show,Data,Typeable) + +-- | CoreErlang expressions. +data Exps + = Exp (Ann Exp) -- ^ single expression + | Exps (Ann [Ann Exp]) -- ^ list of expressions + deriving (Eq,Ord,Show,Data,Typeable) + +-- | CoreErlang expression. +data Exp + = Var Var -- ^ variable + | Lit Literal -- ^ literal constant + | Fun Function -- ^ function name + | App Exps [Exps] -- ^ application + | ModCall (Exps,Exps) [Exps] -- ^ module call + | Lambda [Var] Exps -- ^ lambda expression + | Seq Exps Exps -- ^ sequencing + | Let ([Var],Exps) Exps -- ^ local declaration + | LetRec [FunDef] Exps -- ^ letrec expression + | Case Exps [Ann Alt] -- ^ @case@ /exp/ @of@ /alts/ end + | Tuple [Exps] -- ^ tuple expression + | List (List Exps) -- ^ list expression + | Binary [BitString Exps] -- ^ binary expression + | Op Atom [Exps] -- ^ operator application + | Try Exps ([Var],Exps) ([Var],Exps) -- ^ try expression + | Rec [Ann Alt] TimeOut -- ^ receive expression + | Catch Exps -- ^ catch expression + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A bitstring. +data BitString a + = BitString a [Exps] + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A list of expressions +data List a + = L [a] + | LL [a] a + deriving (Eq,Ord,Show,Data,Typeable) + +-- | An /alt/ in a @case@ expression +data Alt + = Alt Pats Guard Exps + deriving (Eq,Ord,Show,Data,Typeable) + +data Pats + = Pat Pat -- ^ single pattern + | Pats [Pat] -- ^ list of patterns + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A pattern, to be matched against a value. +data Pat + = PVar Var -- ^ variable + | PLit Literal -- ^ literal constant + | PTuple [Pat] -- ^ tuple pattern + | PList (List Pat) -- ^ list pattern + | PBinary [BitString Pat] -- ^ list of bitstring patterns + | PAlias Alias -- ^ alias pattern + deriving (Eq,Ord,Show,Data,Typeable) + +-- | An alias, used in patterns +data Alias + = Alias Var Pat + deriving (Eq,Ord,Show,Data,Typeable) + +-- | A guarded alternative @when@ /exp/ @->@ /exp/. +-- The first expression will be Boolean-valued. +data Guard + = Guard Exps + deriving (Eq,Ord,Show,Data,Typeable) + +-- | The timeout of a receive expression +data TimeOut + = TimeOut Exps Exps + deriving (Eq,Ord,Show,Data,Typeable) + +-- | An annotation for modules, variables, ... +data Ann a + = Constr a -- ^ core erlang construct + | Ann a [Const] -- ^ core erlang annotated construct + deriving (Eq,Ord,Show,Data,Typeable) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ -import Distribution.Simple - -main = defaultMain +import Distribution.Simple + +main = defaultMain