├── Setup.hs ├── AUTHORS ├── README ├── CoreErlang.cabal ├── LICENSE └── Language └── CoreErlang ├── Syntax.hs ├── Parser.hs └── Pretty.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | David Castro Pérez 2 | Henrique Ferreiro García 3 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | CoreErlang is a haskell library which consists on a parser and pretty-printer for the intermediate language used by Erlang. 2 | 3 | The parser uses the Parsec library and the pretty-printer was modelled after the corresponding module of the haskell-src package. It also exposes a Syntax module which allows easy manipulation of terms. 4 | 5 | It is able to parse and pretty print all of Core Erlang. Remaining work includes customizing the pretty printer and refining the syntax interface. 6 | -------------------------------------------------------------------------------- /CoreErlang.cabal: -------------------------------------------------------------------------------- 1 | name: CoreErlang 2 | version: 0.0.4 3 | copyright: 2008, David Castro Pérez, Henrique Ferreiro García 4 | license: BSD3 5 | license-file: LICENSE 6 | author: David Castro Pérez 7 | Henrique Ferreiro García 8 | maintainer: 9 | Alex Kropivny 10 | homepage: http://github.com/amtal/CoreErlang 11 | category: Language 12 | synopsis: Manipulating Core Erlang source code 13 | description: 14 | Facilities for manipulating Core Erlang source code: 15 | an abstract syntax, parser and pretty-printer. 16 | build-type: Simple 17 | cabal-version: >= 1.6 18 | 19 | extra-source-files: 20 | AUTHORS LICENSE 21 | 22 | library 23 | exposed-modules: 24 | Language.CoreErlang.Parser, 25 | Language.CoreErlang.Pretty, 26 | Language.CoreErlang.Syntax 27 | build-depends: 28 | base >=4.8 && <=4.11, 29 | pretty >=1.1 && <1.2, 30 | parsec >=3.1 && <3.2 31 | other-extensions: DeriveDataTypeable 32 | 33 | source-repository head 34 | type: git 35 | location: https://github.com/amtal/CoreErlang.git 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, David Castro Pérez 2 | Henrique Ferreiro García 3 | 4 | This library is derived from code from the GHC project (libraries/haskell-src) 5 | which is largely (c) The University of Glasgow, and distributable under 6 | a BSD-style license. The full text of the license is reproduced below: 7 | 8 | The Glasgow Haskell Compiler License 9 | 10 | Copyright 2004, The University Court of the University of Glasgow. 11 | All rights reserved. 12 | 13 | Redistribution and use in source and binary forms, with or without 14 | modification, are permitted provided that the following conditions are met: 15 | 16 | - Redistributions of source code must retain the above copyright notice, 17 | this list of conditions and the following disclaimer. 18 | 19 | - Redistributions in binary form must reproduce the above copyright notice, 20 | this list of conditions and the following disclaimer in the documentation 21 | and/or other materials provided with the distribution. 22 | 23 | - Neither name of the University nor the names of its contributors may be 24 | used to endorse or promote products derived from this software without 25 | specific prior written permission. 26 | 27 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 28 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 29 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 30 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 31 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 32 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 33 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 34 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 35 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 36 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 37 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 38 | DAMAGE. 39 | -------------------------------------------------------------------------------- /Language/CoreErlang/Syntax.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.CoreErlang.Syntax 4 | -- Copyright : (c) Henrique Ferreiro García 2008 5 | -- (c) David Castro Pérez 2008 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Alex Kropivny 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3. 13 | -- 14 | 15 | ----------------------------------------------------------------------------- 16 | {-# LANGUAGE DeriveDataTypeable #-} 17 | 18 | module Language.CoreErlang.Syntax ( 19 | -- * Modules 20 | Module(..), 21 | -- * Declarations 22 | FunDef(..), 23 | -- * Expressions 24 | Exp(..), Exps(..), Alt(..), Guard(..), 25 | List(..), TimeOut(..), BitString(..), Function(..), 26 | -- * Patterns 27 | Pats(..), Pat(..), Alias(..), 28 | -- * Literals 29 | Literal(..), Const(..), Atom(..), 30 | -- * Variables 31 | Var, 32 | -- * Annotations 33 | Ann(..), 34 | ) where 35 | 36 | import Data.Data 37 | 38 | -- | This type is used to represent variables 39 | type Var = String 40 | 41 | -- | This type is used to represent atoms 42 | data Atom = Atom String 43 | deriving (Eq,Ord,Show,Data,Typeable) 44 | 45 | -- | This type is used to represent function names 46 | data Function = Function (Atom,Integer) 47 | deriving (Eq,Ord,Show,Data,Typeable) 48 | 49 | -- | A CoreErlang source module. 50 | data Module 51 | = Module Atom [Function] [(Atom,Const)] [FunDef] 52 | deriving (Eq,Ord,Show,Data,Typeable) 53 | 54 | -- | This type is used to represent constants 55 | data Const 56 | = CLit Literal 57 | | CTuple [Const] 58 | | CList (List Const) 59 | deriving (Eq,Ord,Show,Data,Typeable) 60 | 61 | -- | This type is used to represent lambdas 62 | data FunDef 63 | = FunDef (Ann Function) (Ann Exp) 64 | deriving (Eq,Ord,Show,Data,Typeable) 65 | 66 | -- | /literal/. 67 | -- Values of this type hold the abstract value of the literal, not the 68 | -- precise string representation used. For example, @10@, @0o12@ and @0xa@ 69 | -- have the same representation. 70 | data Literal 71 | = LChar Char -- ^ character literal 72 | | LString String -- ^ string literal 73 | | LInt Integer -- ^ integer literal 74 | | LFloat Double -- ^ floating point literal 75 | | LAtom Atom -- ^ atom literal 76 | | LNil -- ^ empty list 77 | deriving (Eq,Ord,Show,Data,Typeable) 78 | 79 | -- | CoreErlang expressions. 80 | data Exps 81 | = Exp (Ann Exp) -- ^ single expression 82 | | Exps (Ann [Ann Exp]) -- ^ list of expressions 83 | deriving (Eq,Ord,Show,Data,Typeable) 84 | 85 | -- | CoreErlang expression. 86 | data Exp 87 | = Var Var -- ^ variable 88 | | Lit Literal -- ^ literal constant 89 | | Fun Function -- ^ function name 90 | | App Exps [Exps] -- ^ application 91 | | ModCall (Exps,Exps) [Exps] -- ^ module call 92 | | Lambda [Var] Exps -- ^ lambda expression 93 | | Seq Exps Exps -- ^ sequencing 94 | | Let ([Var],Exps) Exps -- ^ local declaration 95 | | LetRec [FunDef] Exps -- ^ letrec expression 96 | | Case Exps [Ann Alt] -- ^ @case@ /exp/ @of@ /alts/ end 97 | | Tuple [Exps] -- ^ tuple expression 98 | | List (List Exps) -- ^ list expression 99 | | Binary [BitString Exps] -- ^ binary expression 100 | | Op Atom [Exps] -- ^ operator application 101 | | Try Exps ([Var],Exps) ([Var],Exps) -- ^ try expression 102 | | Rec [Ann Alt] TimeOut -- ^ receive expression 103 | | Catch Exps -- ^ catch expression 104 | deriving (Eq,Ord,Show,Data,Typeable) 105 | 106 | -- | A bitstring. 107 | data BitString a 108 | = BitString a [Exps] 109 | deriving (Eq,Ord,Show,Data,Typeable) 110 | 111 | -- | A list of expressions 112 | data List a 113 | = L [a] 114 | | LL [a] a 115 | deriving (Eq,Ord,Show,Data,Typeable) 116 | 117 | -- | An /alt/ in a @case@ expression 118 | data Alt 119 | = Alt Pats Guard Exps 120 | deriving (Eq,Ord,Show,Data,Typeable) 121 | 122 | data Pats 123 | = Pat Pat -- ^ single pattern 124 | | Pats [Pat] -- ^ list of patterns 125 | deriving (Eq,Ord,Show,Data,Typeable) 126 | 127 | -- | A pattern, to be matched against a value. 128 | data Pat 129 | = PVar Var -- ^ variable 130 | | PLit Literal -- ^ literal constant 131 | | PTuple [Pat] -- ^ tuple pattern 132 | | PList (List Pat) -- ^ list pattern 133 | | PBinary [BitString Pat] -- ^ list of bitstring patterns 134 | | PAlias Alias -- ^ alias pattern 135 | deriving (Eq,Ord,Show,Data,Typeable) 136 | 137 | -- | An alias, used in patterns 138 | data Alias 139 | = Alias Var Pat 140 | deriving (Eq,Ord,Show,Data,Typeable) 141 | 142 | -- | A guarded alternative @when@ /exp/ @->@ /exp/. 143 | -- The first expression will be Boolean-valued. 144 | data Guard 145 | = Guard Exps 146 | deriving (Eq,Ord,Show,Data,Typeable) 147 | 148 | -- | The timeout of a receive expression 149 | data TimeOut 150 | = TimeOut Exps Exps 151 | deriving (Eq,Ord,Show,Data,Typeable) 152 | 153 | -- | An annotation for modules, variables, ... 154 | data Ann a 155 | = Constr a -- ^ core erlang construct 156 | | Ann a [Const] -- ^ core erlang annotated construct 157 | deriving (Eq,Ord,Show,Data,Typeable) 158 | -------------------------------------------------------------------------------- /Language/CoreErlang/Parser.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.CoreErlang.Parser 4 | -- Copyright : (c) Henrique Ferreiro García 2008 5 | -- (c) David Castro Pérez 2008 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Alex Kropivny 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- CoreErlang parser. 13 | -- 14 | 15 | ----------------------------------------------------------------------------- 16 | 17 | module Language.CoreErlang.Parser 18 | ( parseModule 19 | , ParseError 20 | ) where 21 | 22 | import Language.CoreErlang.Syntax 23 | 24 | import Control.Monad ( liftM ) 25 | import Data.Char ( isControl, chr ) 26 | import Numeric ( readOct ) 27 | 28 | import Text.ParserCombinators.Parsec 29 | import Text.ParserCombinators.Parsec.Expr 30 | import qualified Text.ParserCombinators.Parsec.Token as Token 31 | import Text.ParserCombinators.Parsec.Token 32 | ( makeTokenParser, TokenParser ) 33 | import Text.ParserCombinators.Parsec.Language 34 | 35 | -- Lexical definitions 36 | 37 | uppercase :: Parser Char 38 | uppercase = upper 39 | 40 | lowercase :: Parser Char 41 | lowercase = lower 42 | 43 | inputchar :: Parser Char 44 | inputchar = noneOf "\n\r" 45 | 46 | control :: Parser Char 47 | control = satisfy isControl 48 | 49 | namechar :: Parser Char 50 | namechar = uppercase <|> lowercase <|> digit <|> oneOf "@_" 51 | 52 | escape :: Parser Char 53 | escape = do char '\\' 54 | s <- octal <|> ctrl <|> escapechar 55 | return s 56 | 57 | octal :: Parser Char 58 | octal = do chars <- tryOctal 59 | let [(o, _)] = readOct chars 60 | return (chr o) 61 | 62 | tryOctal :: Parser [Char] 63 | tryOctal = choice [ try (count 3 octaldigit), 64 | try (count 2 octaldigit), 65 | try (count 1 octaldigit) ] 66 | 67 | octaldigit :: Parser Char 68 | octaldigit = oneOf "01234567" 69 | 70 | ctrl :: Parser Char 71 | ctrl = char '^' >> ctrlchar 72 | 73 | ctrlchar :: Parser Char 74 | ctrlchar = satisfy (`elem` ['\x0040'..'\x005f']) 75 | 76 | escapechar = oneOf "bdefnrstv\"\'\\" 77 | 78 | -- Terminals 79 | 80 | integer :: Parser Integer 81 | integer = do i <- positive <|> negative <|> decimal 82 | whiteSpace -- TODO: buff 83 | return $ i 84 | 85 | positive :: Parser Integer 86 | positive = do char '+' 87 | p <- decimal 88 | return p 89 | 90 | negative :: Parser Integer 91 | negative = do char '-' 92 | n <- decimal 93 | return $ negate n 94 | 95 | -- float :: Parser Double 96 | -- float = sign?digit+.digit+((E|e)sign?digit+)? 97 | 98 | atom :: Parser Atom 99 | atom = do char '\'' 100 | -- ((inputchar except control and \ and ')|escape)* 101 | -- inputchar = noneOf "\n\r" 102 | a <- many (noneOf "\n\r\\\'") 103 | char '\'' 104 | whiteSpace -- TODO: buff 105 | return $ Atom a 106 | 107 | echar :: Parser Literal 108 | -- char = $((inputchar except control and space and \)|escape) 109 | echar = do char '$' 110 | c <- noneOf "\n\r\\ " 111 | whiteSpace -- TODO: buff 112 | return $ LChar c 113 | 114 | estring :: Parser Literal 115 | -- string = "((inputchar except control and \\ and \"")|escape)*" 116 | estring = do char '"' 117 | s <- many $ noneOf "\n\r\\\"" 118 | char '"' 119 | return $ LString s 120 | 121 | variable :: Parser Var 122 | -- variable = (uppercase | (_ namechar)) namechar* 123 | variable = identifier 124 | 125 | -- Non-terminals 126 | 127 | emodule :: Parser (Ann Module) 128 | emodule = annotated amodule 129 | 130 | amodule :: Parser Module 131 | amodule = do reserved "module" 132 | name <- atom 133 | funs <- exports 134 | attrs <- attributes 135 | fundefs <- many fundef 136 | reserved "end" 137 | return $ Module name funs attrs fundefs 138 | 139 | exports :: Parser [Function] 140 | exports = brackets $ commaSep function 141 | 142 | attributes :: Parser [(Atom,Const)] 143 | attributes = do reserved "attributes" 144 | brackets (commaSep $ do a <- atom 145 | symbol "=" 146 | c <- constant 147 | return (a,c)) 148 | 149 | constant :: Parser Const 150 | constant = liftM CLit (try literal) <|> 151 | liftM CTuple (tuple constant) <|> 152 | liftM CList (elist constant) 153 | 154 | fundef :: Parser FunDef 155 | fundef = do name <- annotated function 156 | symbol "=" 157 | body <- annotated lambda 158 | return $ FunDef name body 159 | 160 | function :: Parser Function 161 | function = do a <- atom 162 | char '/' 163 | i <- decimal 164 | whiteSpace -- TODO: buff 165 | return $ Function (a,i) 166 | 167 | literal :: Parser Literal 168 | literal = try (liftM LFloat float) <|> liftM LInt integer <|> 169 | liftM LAtom atom <|> nil <|> echar <|> estring 170 | 171 | nil :: Parser Literal 172 | nil = brackets (return LNil) 173 | 174 | expression :: Parser Exps 175 | expression = try (liftM Exps (annotated $ angles $ commaSep (annotated sexpression))) <|> 176 | liftM Exp (annotated sexpression) 177 | 178 | sexpression :: Parser Exp 179 | sexpression = app <|> ecatch <|> ecase <|> elet <|> 180 | liftM Fun (try function) {- because of atom -} <|> 181 | lambda <|> letrec <|> liftM Binary (ebinary expression) <|> 182 | liftM List (try $ elist expression) {- because of nil -} <|> 183 | liftM Lit literal <|> modcall <|> op <|> receive <|> 184 | eseq <|> etry <|> liftM Tuple (tuple expression) <|> 185 | liftM Var variable 186 | 187 | app :: Parser Exp 188 | app = do reserved "apply" 189 | e1 <- expression 190 | eN <- parens $ commaSep expression 191 | return $ App e1 eN 192 | 193 | ecatch :: Parser Exp 194 | ecatch = do reserved "catch" 195 | e <- expression 196 | return $ Catch e 197 | 198 | ebinary :: Parser a -> Parser [BitString a] 199 | ebinary p = do symbol "#" 200 | bs <- braces (commaSep (bitstring p)) 201 | symbol "#" 202 | return bs 203 | 204 | bitstring :: Parser a -> Parser (BitString a) 205 | bitstring p = do symbol "#" 206 | e0 <- angles p 207 | es <- parens (commaSep expression) 208 | return $ BitString e0 es 209 | 210 | ecase :: Parser Exp 211 | ecase = do reserved "case" 212 | exp <- expression 213 | reserved "of" 214 | alts <- many1 (annotated clause) 215 | reserved "end" 216 | return $ Case exp alts 217 | 218 | clause :: Parser Alt 219 | clause = do pat <- patterns 220 | g <- guard 221 | symbol "->" 222 | exp <- expression 223 | return $ Alt pat g exp 224 | 225 | patterns :: Parser Pats 226 | patterns = liftM Pat pattern <|> 227 | liftM Pats (angles $ commaSep pattern) 228 | 229 | pattern :: Parser Pat 230 | pattern = liftM PAlias (try alias) {- because of variable -} <|> liftM PVar variable <|> 231 | liftM PLit (try literal) {- because of nil -} <|> liftM PTuple (tuple pattern) <|> 232 | liftM PList (elist pattern) <|> liftM PBinary (ebinary pattern) 233 | 234 | alias :: Parser Alias 235 | alias = do v <- variable 236 | symbol "=" 237 | p <- pattern 238 | return $ Alias v p 239 | 240 | guard :: Parser Guard 241 | guard = do reserved "when" 242 | e <- expression 243 | return $ Guard e 244 | 245 | elet :: Parser Exp 246 | elet = do reserved "let" 247 | vars <- variables 248 | symbol "=" 249 | e1 <- expression 250 | symbol "in" 251 | e2 <- expression 252 | return $ Let (vars,e1) e2 253 | 254 | variables :: Parser [Var] 255 | variables = do { v <- variable; return [v]} <|> (angles $ commaSep variable) 256 | 257 | lambda :: Parser Exp 258 | lambda = do reserved "fun" 259 | vars <- parens $ commaSep variable 260 | symbol "->" 261 | expr <- expression 262 | return $ Lambda vars expr 263 | 264 | letrec :: Parser Exp 265 | letrec = do reserved "letrec" 266 | defs <- many fundef 267 | reserved "in" 268 | e <- expression 269 | return $ LetRec defs e 270 | 271 | elist :: Parser a -> Parser (List a) 272 | elist a = brackets $ list a 273 | 274 | list :: Parser a -> Parser (List a) 275 | list elem = do elems <- commaSep1 elem 276 | option (L elems) (do symbol "|" 277 | t <- elem 278 | return $ LL elems t) 279 | 280 | modcall :: Parser Exp 281 | modcall = do reserved "call" 282 | e1 <- expression 283 | symbol ":" 284 | e2 <- expression 285 | eN <- parens $ commaSep expression 286 | return $ ModCall (e1, e2) eN 287 | 288 | op :: Parser Exp 289 | op = do reserved "primop" 290 | a <- atom 291 | e <- parens $ commaSep expression 292 | return $ Op a e 293 | 294 | receive :: Parser Exp 295 | receive = do reserved "receive" 296 | alts <- many $ annotated clause 297 | to <- timeout 298 | return $ Rec alts to 299 | 300 | timeout :: Parser TimeOut 301 | timeout = do reserved "after" 302 | e1 <- expression 303 | symbol "->" 304 | e2 <- expression 305 | return $ TimeOut e1 e2 306 | 307 | eseq :: Parser Exp 308 | eseq = do reserved "do" 309 | e1 <- expression 310 | e2 <- expression 311 | return $ Seq e1 e2 312 | 313 | etry :: Parser Exp 314 | etry = do reserved "try" 315 | e1 <- expression 316 | reserved "of" 317 | v1 <- variables 318 | symbol "->" 319 | e2 <- expression 320 | reserved "catch" 321 | v2 <- variables 322 | symbol "->" 323 | e3 <- expression 324 | return $ Try e1 (v1,e1) (v2,e2) 325 | 326 | tuple :: Parser a -> Parser [a] 327 | tuple elem = braces $ commaSep elem 328 | 329 | annotation :: Parser [Const] 330 | annotation = do symbol "-|" 331 | cs <- brackets $ many constant 332 | return $ cs 333 | 334 | annotated :: Parser a -> Parser (Ann a) 335 | annotated p = parens (do e <- p 336 | cs <- annotation 337 | return $ Ann e cs) 338 | <|> 339 | do e <- p 340 | return $ Constr e 341 | 342 | lexer :: TokenParser () 343 | lexer = makeTokenParser 344 | (emptyDef { 345 | -- commentStart = "", 346 | -- commentEnd = "", 347 | commentLine = "%", 348 | -- nestedComments = True, 349 | identStart = upper <|> char '_', 350 | identLetter = namechar 351 | -- opStart, 352 | -- opLetter, 353 | -- reservedNames, 354 | -- reservedOpNames, 355 | -- caseSensitive = True, 356 | }) 357 | 358 | angles = Token.angles lexer 359 | braces = Token.braces lexer 360 | brackets = Token.brackets lexer 361 | commaSep = Token.commaSep lexer 362 | commaSep1 = Token.commaSep1 lexer 363 | decimal = Token.decimal lexer 364 | float = Token.float lexer 365 | identifier = Token.identifier lexer 366 | natural = Token.natural lexer 367 | parens = Token.parens lexer 368 | reserved = Token.reserved lexer 369 | reservedOp = Token.reservedOp lexer 370 | symbol = Token.symbol lexer 371 | whiteSpace = Token.whiteSpace lexer 372 | 373 | runLex :: Show a => Parser a -> String -> IO () 374 | runLex p file = do input <- readFile file 375 | parseTest (do whiteSpace 376 | x <- p 377 | eof 378 | return x) input 379 | return () 380 | 381 | -- | Parse of a string, which should contain a complete CoreErlang module 382 | parseModule :: String -> Either ParseError (Ann Module) 383 | parseModule input = parse (do whiteSpace 384 | x <- emodule 385 | eof 386 | return x) "" input 387 | -------------------------------------------------------------------------------- /Language/CoreErlang/Pretty.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.CoreErlang.Pretty 4 | -- Copyright : (c) Henrique Ferreiro García 2008 5 | -- (c) David Castro Pérez 2008 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Alex Kropivny 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- Pretty printer for CoreErlang. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.CoreErlang.Pretty ( 17 | -- * Pretty printing 18 | Pretty, 19 | prettyPrintStyleMode, prettyPrintWithMode, prettyPrint, 20 | -- * Pretty-printing styles (from -- "Text.PrettyPrint.HughesPJ") 21 | P.Style(..), P.style, P.Mode(..), 22 | -- * CoreErlang formatting modes 23 | PPMode(..), Indent, PPLayout(..), defaultMode) where 24 | 25 | import Language.CoreErlang.Syntax 26 | 27 | import qualified Text.PrettyPrint as P 28 | 29 | infixl 5 $$$ 30 | 31 | ------------------------------------------------------------------------------- 32 | 33 | -- | Varieties of layout we can use. 34 | data PPLayout = PPDefault -- ^ classical layout 35 | | PPNoLayout -- ^ everything on a single line 36 | deriving Eq 37 | 38 | type Indent = Int 39 | 40 | -- | Pretty-printing parameters. 41 | data PPMode = PPMode { 42 | altIndent :: Indent, -- ^ indentation of the alternatives 43 | -- in a @case@ expression 44 | caseIndent :: Indent, -- ^ indentation of the declarations 45 | -- in a @case@ expression 46 | fundefIndent :: Indent, -- ^ indentation of the declarations 47 | -- in a function definition 48 | lambdaIndent :: Indent, -- ^ indentation of the declarations 49 | -- in a @lambda@ expression 50 | letIndent :: Indent, -- ^ indentation of the declarations 51 | -- in a @let@ expression 52 | letrecIndent :: Indent, -- ^ indentation of the declarations 53 | -- in a @letrec@ expression 54 | onsideIndent :: Indent, -- ^ indentation added for continuation 55 | -- lines that would otherwise be offside 56 | layout :: PPLayout -- ^ Pretty-printing style to use 57 | } 58 | 59 | -- | The default mode: pretty-print using sensible defaults. 60 | defaultMode :: PPMode 61 | defaultMode = PPMode { 62 | altIndent = 4, 63 | caseIndent = 4, 64 | fundefIndent = 4, 65 | lambdaIndent = 4, 66 | letIndent = 4, 67 | letrecIndent = 4, 68 | onsideIndent = 4, 69 | layout = PPDefault 70 | } 71 | 72 | -- | Pretty printing monad 73 | newtype DocM s a = DocM (s -> a) 74 | 75 | instance Functor (DocM s) where 76 | fmap f xs = do x <- xs; return (f x) 77 | 78 | instance Applicative (DocM s) where 79 | pure = return 80 | (<*>) m1 m2 = do x1 <- m1; x2 <- m2; return (x1 x2) 81 | 82 | instance Monad (DocM s) where 83 | (>>=) = thenDocM 84 | (>>) = then_DocM 85 | return = retDocM 86 | 87 | {-# INLINE thenDocM #-} 88 | {-# INLINE then_DocM #-} 89 | {-# INLINE retDocM #-} 90 | {-# INLINE unDocM #-} 91 | {-# INLINE getPPEnv #-} 92 | 93 | thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b 94 | thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s) 95 | 96 | then_DocM :: DocM s a -> DocM s b -> DocM s b 97 | then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s) 98 | 99 | retDocM :: a -> DocM s a 100 | retDocM a = DocM (\_s -> a) 101 | 102 | unDocM :: DocM s a -> (s -> a) 103 | unDocM (DocM f) = f 104 | 105 | -- all this extra stuff, just for this one function. 106 | getPPEnv :: DocM s s 107 | getPPEnv = DocM id 108 | 109 | -- | The document type produced by these pretty printers uses a 'PPMode' 110 | -- environment. 111 | type Doc = DocM PPMode P.Doc 112 | 113 | -- | Things that can be pretty-printed, including all the syntactic objects 114 | -- in "Language.CoreErlang.Syntax". 115 | class Pretty a where 116 | -- | Pretty-print something in isolation. 117 | pretty :: a -> Doc 118 | -- | Pretty-print something in a precedence context. 119 | prettyPrec :: Int -> a -> Doc 120 | pretty = prettyPrec 0 121 | prettyPrec _ = pretty 122 | 123 | -- The pretty printing combinators 124 | 125 | empty :: Doc 126 | empty = return P.empty 127 | 128 | nest :: Int -> Doc -> Doc 129 | nest i m = m >>= return . P.nest i 130 | 131 | -- Literals 132 | text, ptext :: String -> Doc 133 | text = return . P.text 134 | ptext = return . P.text 135 | 136 | char :: Char -> Doc 137 | char = return . P.char 138 | 139 | int :: Int -> Doc 140 | int = return . P.int 141 | 142 | integer :: Integer -> Doc 143 | integer = return . P.integer 144 | 145 | float :: Float -> Doc 146 | float = return . P.float 147 | 148 | double :: Double -> Doc 149 | double = return . P.double 150 | 151 | -- Simple Combining Forms 152 | parens, brackets, braces, quotes, doubleQuotes :: Doc -> Doc 153 | parens d = d >>= return . P.parens 154 | brackets d = d >>= return . P.brackets 155 | braces d = d >>= return . P.braces 156 | quotes d = d >>= return . P.quotes 157 | doubleQuotes d = d >>= return . P.doubleQuotes 158 | 159 | parensIf :: Bool -> Doc -> Doc 160 | parensIf True = parens 161 | parensIf False = id 162 | 163 | -- Constants 164 | semi, comma, colon, space, equals :: Doc 165 | semi = return P.semi 166 | comma = return P.comma 167 | colon = return P.colon 168 | space = return P.space 169 | equals = return P.equals 170 | 171 | lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc 172 | lparen = return P.lparen 173 | rparen = return P.rparen 174 | lbrack = return P.lbrack 175 | rbrack = return P.rbrack 176 | lbrace = return P.lbrace 177 | rbrace = return P.rbrace 178 | 179 | -- Combinators 180 | 181 | (<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc 182 | aM <> bM = do { a <- aM; b <- bM; return $ a P.<> b} 183 | aM <+> bM = do { a <- aM; b <- bM; return $ a P.<+> b} 184 | aM $$ bM = do { a <- aM; b <- bM; return $ a P.$$ b} 185 | aM $+$ bM = do { a <- aM; b <- bM; return $ a P.$+$ b} 186 | 187 | hcat, hsep, vcat, sep, cat, fsep, fcat :: [Doc] -> Doc 188 | hcat dl = sequence dl >>= return . P.hcat 189 | hsep dl = sequence dl >>= return . P.hsep 190 | vcat dl = sequence dl >>= return . P.vcat 191 | sep dl = sequence dl >>= return . P.sep 192 | cat dl = sequence dl >>= return . P.cat 193 | fsep dl = sequence dl >>= return . P.fsep 194 | fcat dl = sequence dl >>= return . P.fcat 195 | 196 | -- Some More 197 | 198 | hang :: Doc -> Int -> Doc -> Doc 199 | hang dM i rM = do { d <- dM; r <- rM; return $ P.hang d i r } 200 | 201 | -- Yuk, had to cut-n-paste this one from Pretty.hs 202 | punctuate :: Doc -> [Doc] -> [Doc] 203 | punctuate _ [] = [] 204 | punctuate p (d1:ds) = go d1 ds 205 | where 206 | go d [] = [d] 207 | go d (e:es) = (d <> p) : go e es 208 | 209 | -- | render the document with a given style and mode. 210 | renderStyleMode :: P.Style -> PPMode -> Doc -> String 211 | renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode 212 | 213 | -- | render the document with a given mode. 214 | renderWithMode :: PPMode -> Doc -> String 215 | renderWithMode = renderStyleMode P.style 216 | 217 | -- | render the document with defaultMode 218 | render :: Doc -> String 219 | render = renderWithMode defaultMode 220 | 221 | -- | pretty-print with a given style and mode. 222 | prettyPrintStyleMode :: Pretty a => P.Style -> PPMode -> a -> String 223 | prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty 224 | 225 | -- | pretty-print with the default style and a given mode. 226 | prettyPrintWithMode :: Pretty a => PPMode -> a -> String 227 | prettyPrintWithMode = prettyPrintStyleMode P.style 228 | 229 | -- | pretty-print with the default style and 'defaultMode'. 230 | prettyPrint :: Pretty a => a -> String 231 | prettyPrint = prettyPrintWithMode defaultMode 232 | 233 | fullRenderWithMode :: PPMode -> P.Mode -> Int -> Float -> 234 | (P.TextDetails -> a -> a) -> a -> Doc -> a 235 | fullRenderWithMode ppMode m i f fn e mD = 236 | P.fullRender m i f fn e $ (unDocM mD) ppMode 237 | 238 | fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) 239 | -> a -> Doc -> a 240 | fullRender = fullRenderWithMode defaultMode 241 | 242 | ------------------------- Pretty-Print a Module -------------------- 243 | instance Pretty Module where 244 | pretty (Module m exports attrs fundefs) = 245 | topLevel (ppModuleHeader m exports attrs) 246 | (map pretty fundefs) 247 | 248 | -------------------------- Module Header ------------------------------ 249 | ppModuleHeader :: Atom -> [Function] -> [(Atom,Const)] -> Doc 250 | ppModuleHeader m exports attrs = myFsep [ 251 | text "module" <+> pretty m <+> (bracketList $ map pretty exports), 252 | text "attributes" <+> bracketList (map ppAssign attrs)] 253 | 254 | instance Pretty Function where 255 | pretty (Function (name,arity)) = 256 | pretty name <> char '/' <> integer arity 257 | 258 | instance Pretty Const where 259 | pretty (CLit l) = pretty l 260 | pretty (CTuple l) = ppTuple l 261 | pretty (CList l) = pretty l 262 | 263 | ------------------------- Declarations ------------------------------ 264 | instance Pretty FunDef where 265 | pretty (FunDef function exp) = (pretty function <+> char '=') $$$ 266 | ppBody fundefIndent [pretty exp] 267 | 268 | ------------------------- Expressions ------------------------- 269 | instance Pretty Literal where 270 | pretty (LChar c) = char c 271 | pretty (LString s) = text (show s) 272 | pretty (LInt i) = integer i 273 | pretty (LFloat f) = double f 274 | pretty (LAtom a) = pretty a 275 | pretty LNil = bracketList [empty] 276 | 277 | instance Pretty Atom where 278 | pretty (Atom a) = char '\'' <> text a <> char '\'' 279 | 280 | instance Pretty Exps where 281 | pretty (Exp e) = pretty e 282 | pretty (Exps (Constr e)) = angleList (map pretty e) 283 | pretty (Exps (Ann e cs)) = parens (angleList (map pretty e) 284 | $$$ ppAnn cs) 285 | 286 | instance Pretty Exp where 287 | pretty (Var v) = text v 288 | pretty (Lit l) = pretty l 289 | pretty (Fun f) = pretty f 290 | pretty (App e exps) = text "apply" <+> 291 | pretty e <> parenList (map pretty exps) 292 | pretty (ModCall (e1,e2) exps) = sep [text "call" <+> 293 | pretty e1 <> char ':' <> pretty e2, 294 | parenList (map pretty exps)] 295 | pretty (Lambda vars e) = sep [text "fun" <> parenList (map text vars) <+> text "->", 296 | ppBody lambdaIndent [pretty e]] 297 | pretty (Seq e1 e2) = sep [text "do", pretty e1, pretty e2] 298 | pretty (Let (vars,e1) e2) = text "let" <+> 299 | angleList (map text vars) <+> 300 | char '=' <+> pretty e1 301 | $$$ text "in" <+> pretty e2 302 | pretty (LetRec fundefs e) = sep [text "letrec" <+> 303 | ppBody letrecIndent (map pretty fundefs), 304 | text "in", pretty e] 305 | pretty (Case e alts) = sep [text "case", pretty e, text "of"] 306 | $$$ ppBody caseIndent (map pretty alts) 307 | $$$ text "end" 308 | pretty (Tuple exps) = braceList $ map pretty exps 309 | pretty (List l) = pretty l 310 | pretty (Op a exps) = text "primop" <+> pretty a <> parenList (map pretty exps) 311 | pretty (Binary bs) = char '#' <> braceList (map pretty bs) <> char '#' 312 | pretty (Try e (vars1,exps1) (vars2,exps2)) = text "try" 313 | $$$ ppBody caseIndent [pretty e] 314 | $$$ text "of" <+> angleList (map text vars1) <+> text "->" 315 | $$$ ppBody altIndent [pretty exps1] 316 | $$$ text "catch" <+> angleList (map text vars2) <+> text "->" 317 | $$$ ppBody altIndent [pretty exps2] 318 | pretty (Rec alts tout) = text "receive" 319 | $$$ ppBody caseIndent (map pretty alts) 320 | $$$ text "after" 321 | $$$ ppBody caseIndent [pretty tout] 322 | pretty (Catch e) = sep [text "catch", pretty e] 323 | 324 | instance Pretty a => Pretty (List a) where 325 | pretty (L l) = bracketList $ map pretty l 326 | pretty (LL h t) = brackets . hcat $ punctuate comma (map pretty h) ++ 327 | [char '|' <> pretty t] 328 | instance Pretty Alt where 329 | pretty (Alt pats guard exps) = 330 | myFsep [pretty pats, pretty guard <+> text "->"] 331 | $$$ ppBody altIndent [pretty exps] 332 | 333 | instance Pretty Pats where 334 | pretty (Pat p) = pretty p 335 | pretty (Pats p) = angleList (map pretty p) 336 | 337 | instance Pretty Pat where 338 | pretty (PVar v) = text v 339 | pretty (PLit l) = pretty l 340 | pretty (PTuple p) = braceList $ map pretty p 341 | pretty (PList l) = pretty l 342 | pretty (PBinary bs) = char '#' <> braceList (map pretty bs) <> char '#' 343 | pretty (PAlias a) = pretty a 344 | 345 | instance Pretty Alias where 346 | pretty (Alias v p) = ppAssign (Var v,p) -- FIXME: hack! 347 | 348 | instance Pretty Guard where 349 | pretty (Guard e) = text "when" <+> pretty e 350 | 351 | instance Pretty TimeOut where 352 | pretty (TimeOut e1 e2) = pretty e1 <+> text "->" 353 | $$$ ppBody altIndent [pretty e2] 354 | 355 | instance Pretty a => Pretty (BitString a) where 356 | pretty (BitString e es) = text "#<" <> pretty e <> char '>' <> parenList (map pretty es) 357 | 358 | ----------------------- Annotations ------------------------ 359 | instance Pretty a => Pretty (Ann a) where 360 | pretty (Constr a) = pretty a 361 | pretty (Ann a cs) = parens (pretty a $$$ ppAnn cs) 362 | 363 | 364 | ------------------------- pp utils ------------------------- 365 | angles :: Doc -> Doc 366 | angles p = char '<' <> p <> char '>' 367 | 368 | angleList :: [Doc] -> Doc 369 | angleList = angles . myFsepSimple . punctuate comma 370 | 371 | braceList :: [Doc] -> Doc 372 | braceList = braces . myFsepSimple . punctuate comma 373 | 374 | bracketList :: [Doc] -> Doc 375 | bracketList = brackets . myFsepSimple . punctuate comma 376 | 377 | parenList :: [Doc] -> Doc 378 | parenList = parens . myFsepSimple . punctuate comma 379 | 380 | -- | Monadic PP Combinators -- these examine the env 381 | topLevel :: Doc -> [Doc] -> Doc 382 | topLevel header dl = do e <- fmap layout getPPEnv 383 | let s = case e of 384 | PPDefault -> header $$ vcat dl 385 | PPNoLayout -> header <+> hsep dl 386 | s $$$ text "end" 387 | 388 | ppAssign :: (Pretty a,Pretty b) => (a,b) -> Doc 389 | ppAssign (a,b) = pretty a <+> char '=' <+> pretty b 390 | 391 | ppTuple :: Pretty a => [a] -> Doc 392 | ppTuple t = braceList (map pretty t) 393 | 394 | ppBody :: (PPMode -> Int) -> [Doc] -> Doc 395 | ppBody f dl = do e <- fmap layout getPPEnv 396 | i <- fmap f getPPEnv 397 | case e of 398 | PPDefault -> nest i . vcat $ dl 399 | _ -> hsep dl 400 | 401 | ($$$) :: Doc -> Doc -> Doc 402 | a $$$ b = layoutChoice (a $$) (a <+>) b 403 | 404 | myFsepSimple :: [Doc] -> Doc 405 | myFsepSimple = layoutChoice fsep hsep 406 | 407 | -- same, except that continuation lines are indented, 408 | -- which is necessary to avoid triggering the offside rule. 409 | myFsep :: [Doc] -> Doc 410 | myFsep = layoutChoice fsep' hsep 411 | where fsep' [] = empty 412 | fsep' (d:ds) = do 413 | e <- getPPEnv 414 | let n = onsideIndent e 415 | nest n (fsep (nest (-n) d:ds)) 416 | 417 | layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc 418 | layoutChoice a b dl = do e <- getPPEnv 419 | if layout e == PPDefault 420 | then a dl 421 | else b dl 422 | 423 | ppAnn :: (Pretty a) => [a] -> Doc 424 | ppAnn cs = text "-|" <+> bracketList (map pretty cs) 425 | --------------------------------------------------------------------------------