CoreErlang 0.0.3 → 0.0.4
raw patch · 7 files changed
+1045/−1045 lines, 7 filesdep ~basesetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
- Language.CoreErlang.Pretty: class Pretty a where pretty = prettyPrec 0 prettyPrec _ = pretty
+ Language.CoreErlang.Pretty: class Pretty a
Files
- AUTHORS +2/−2
- CoreErlang.cabal +35/−35
- LICENSE +38/−38
- Language/CoreErlang/Parser.hs +386/−386
- Language/CoreErlang/Pretty.hs +424/−424
- Language/CoreErlang/Syntax.hs +157/−157
- Setup.hs +3/−3
AUTHORS view
@@ -1,2 +1,2 @@-David Castro Pérez <dcastrop@udc.es> -Henrique Ferreiro García <hferreiro@udc.es> +David Castro Pérez <dcastrop@udc.es>+Henrique Ferreiro García <hferreiro@udc.es>
CoreErlang.cabal view
@@ -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 <dcastrop@udc.es> - Henrique Ferreiro García <hferreiro@udc.es> -maintainer: - Alex Kropivny <alex.kropivny@gmail.com> -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 <dcastrop@udc.es>+ Henrique Ferreiro García <hferreiro@udc.es>+maintainer: + Alex Kropivny <alex.kropivny@gmail.com>+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
LICENSE view
@@ -1,38 +1,38 @@-Copyright (c) 2008, David Castro Pérez <dcastrop@udc.es> - Henrique Ferreiro García <hferreiro@udc.es> - -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 <dcastrop@udc.es>+ Henrique Ferreiro García <hferreiro@udc.es>++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.
Language/CoreErlang/Parser.hs view
@@ -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 <alex.kropivny@gmail.com> --- Stability : experimental --- Portability : portable --- --- CoreErlang parser. --- <http://www.it.uu.se/research/group/hipe/cerl/> - ------------------------------------------------------------------------------ - -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 <alex.kropivny@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- CoreErlang parser.+-- <http://www.it.uu.se/research/group/hipe/cerl/>++-----------------------------------------------------------------------------++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
Language/CoreErlang/Pretty.hs view
@@ -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 <alex.kropivny@gmail.com> --- 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 <alex.kropivny@gmail.com>+-- 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)
Language/CoreErlang/Syntax.hs view
@@ -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 <alex.kropivny@gmail.com> --- Stability : experimental --- Portability : portable --- --- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3. --- <http://www.it.uu.se/research/group/hipe/cerl/> - ------------------------------------------------------------------------------ -{-# 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 <alex.kropivny@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3.+-- <http://www.it.uu.se/research/group/hipe/cerl/>++-----------------------------------------------------------------------------+{-# 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)
Setup.hs view
@@ -1,3 +1,3 @@-import Distribution.Simple - -main = defaultMain +import Distribution.Simple++main = defaultMain