CoreErlang 0.0.2 → 0.0.3

raw patch · 7 files changed

+1045/−1041 lines, 7 filesdep ~basedep ~parsecdep ~prettysetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, parsec, pretty

API changes (from Hackage documentation)

Files

• AUTHORS +2/−2
• CoreErlang.cabal +35/−32
• LICENSE +38/−38
• Language/CoreErlang/Parser.hs +386/−386
• Language/CoreErlang/Pretty.hs +424/−420
• Language/CoreErlang/Syntax.hs +157/−157
• Setup.hs +3/−6

@@ -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>

@@ -1,32 +1,35 @@-name: CoreErlang-version: 0.0.2-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-stability: Experimental-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.2--extra-source-files:-    AUTHORS LICENSE--flag split-base--library-  exposed-modules:-        Language.CoreErlang.Parser,-        Language.CoreErlang.Pretty,-        Language.CoreErlang.Syntax-  if flag(split-base)-    build-depends:	base >= 3 && < 5, parsec >= 2.1.0.0, pretty-  else-    build-depends:	base < 3, parsec >= 2.1.0.0+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

@@ -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.

@@ -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

@@ -1,420 +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 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)

@@ -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)

@@ -1,6 +1,3 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain+import Distribution.Simple
+
+main = defaultMain