diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +David Castro Pérez +Henrique Ferreiro García diff --git a/CoreErlang.cabal b/CoreErlang.cabal new file mode 100644 --- /dev/null +++ b/CoreErlang.cabal @@ -0,0 +1,33 @@ +name: CoreErlang +version: 0.0.1 +copyright: 2008, David Castro Pérez, Henrique Ferreiro García +license: BSD3 +license-file: LICENSE +author: David Castro Pérez + Henrique Ferreiro García +maintainer: Henrique Ferreiro García + David Castro Pérez +homepage: . +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, parsec == 2.1.0.0, pretty + else + build-depends: base < 3, parsec == 2.1.0.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,38 @@ +Copyright (c) 2008, David Castro Pérez + Henrique Ferreiro García + +This library is derived from code from the GHC project (libraries/haskell-src) +which is largely (c) The University of Glasgow, and distributable under +a BSD-style license. The full text of the license is reproduced below: + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Language/CoreErlang/Parser.hs b/Language/CoreErlang/Parser.hs new file mode 100644 --- /dev/null +++ b/Language/CoreErlang/Parser.hs @@ -0,0 +1,387 @@ +----------------------------------------------------------------------------- +-- | +-- 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 : Henrique Ferreiro García +-- David Castro Pérez +-- Stability : experimental +-- Portability : portable +-- +-- CoreErlang parser. +-- + +----------------------------------------------------------------------------- + +module Language.CoreErlang.Parser + ( parseModule + , ParseError + ) where + +import Language.CoreErlang.Syntax + +import Control.Monad ( liftM ) +import Data.Char ( isControl, chr ) +import Numeric ( readOct ) + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import qualified Text.ParserCombinators.Parsec.Token as Token +import Text.ParserCombinators.Parsec.Token + ( makeTokenParser, TokenParser ) +import Text.ParserCombinators.Parsec.Language + +-- Lexical definitions + +uppercase :: Parser Char +uppercase = upper + +lowercase :: Parser Char +lowercase = lower + +inputchar :: Parser Char +inputchar = noneOf "\n\r" + +control :: Parser Char +control = satisfy isControl + +namechar :: Parser Char +namechar = uppercase <|> lowercase <|> digit <|> oneOf "@_" + +escape :: Parser Char +escape = do char '\\' + s <- octal <|> ctrl <|> escapechar + return s + +octal :: Parser Char +octal = do chars <- tryOctal + let [(o, _)] = readOct chars + return (chr o) + +tryOctal :: Parser [Char] +tryOctal = choice [ try (count 3 octaldigit), + try (count 2 octaldigit), + try (count 1 octaldigit) ] + +octaldigit :: Parser Char +octaldigit = oneOf "01234567" + +ctrl :: Parser Char +ctrl = char '^' >> ctrlchar + +ctrlchar :: Parser Char +ctrlchar = satisfy (`elem` ['\x0040'..'\x005f']) + +escapechar = oneOf "bdefnrstv\"\'\\" + +-- Terminals + +integer :: Parser Integer +integer = do i <- positive <|> negative <|> decimal + whiteSpace -- TODO: buff + return $ i + +positive :: Parser Integer +positive = do char '+' + p <- decimal + return p + +negative :: Parser Integer +negative = do char '-' + n <- decimal + return $ negate n + +-- float :: Parser Double +-- float = sign?digit+.digit+((E|e)sign?digit+)? + +atom :: Parser Atom +atom = do char '\'' +-- ((inputchar except control and \ and ')|escape)* +-- inputchar = noneOf "\n\r" + a <- many (noneOf "\n\r\\\'") + char '\'' + whiteSpace -- TODO: buff + return $ Atom a + +echar :: Parser Literal +-- char = $((inputchar except control and space and \)|escape) +echar = do char '$' + c <- noneOf "\n\r\\ " + whiteSpace -- TODO: buff + return $ LChar c + +estring :: Parser Literal +-- string = "((inputchar except control and \\ and \"")|escape)*" +estring = do char '"' + s <- many $ noneOf "\n\r\\\"" + char '"' + return $ LString s + +variable :: Parser Var +-- variable = (uppercase | (_ namechar)) namechar* +variable = identifier + +-- Non-terminals + +emodule :: Parser (Ann Module) +emodule = annotated amodule + +amodule :: Parser Module +amodule = do reserved "module" + name <- atom + funs <- exports + attrs <- attributes + fundefs <- many fundef + reserved "end" + return $ Module name funs attrs fundefs + +exports :: Parser [Function] +exports = brackets $ commaSep function + +attributes :: Parser [(Atom,Const)] +attributes = do reserved "attributes" + brackets (commaSep $ do a <- atom + symbol "=" + c <- constant + return (a,c)) + +constant :: Parser Const +constant = liftM CLit (try literal) <|> + liftM CTuple (tuple constant) <|> + liftM CList (elist constant) + +fundef :: Parser FunDef +fundef = do name <- annotated function + symbol "=" + body <- annotated lambda + return $ FunDef name body + +function :: Parser Function +function = do a <- atom + char '/' + i <- decimal + whiteSpace -- TODO: buff + return $ Function (a,i) + +literal :: Parser Literal +literal = liftM LInt integer <|> liftM LFloat float <|> + liftM LAtom atom <|> nil <|> echar <|> estring + +nil :: Parser Literal +nil = brackets (return LNil) + +expression :: Parser Exps +expression = try (liftM Exps (annotated $ angles $ commaSep (annotated sexpression))) <|> + liftM Exp (annotated sexpression) + +sexpression :: Parser Exp +sexpression = app <|> ecatch <|> ecase <|> elet <|> + liftM Fun (try function) {- because of atom -} <|> + lambda <|> letrec <|> liftM Binary (ebinary expression) <|> + liftM List (try $ elist expression) {- because of nil -} <|> + liftM Lit literal <|> modcall <|> op <|> receive <|> + eseq <|> etry <|> liftM Tuple (tuple expression) <|> + liftM Var variable + +app :: Parser Exp +app = do reserved "apply" + e1 <- expression + eN <- parens $ commaSep expression + return $ App e1 eN + +ecatch :: Parser Exp +ecatch = do reserved "catch" + e <- expression + return $ Catch e + +ebinary :: Parser a -> Parser [BitString a] +ebinary p = do symbol "#" + bs <- braces (commaSep (bitstring p)) + symbol "#" + return bs + +bitstring :: Parser a -> Parser (BitString a) +bitstring p = do symbol "#" + e0 <- angles p + es <- parens (commaSep expression) + return $ BitString e0 es + +ecase :: Parser Exp +ecase = do reserved "case" + exp <- expression + reserved "of" + alts <- many1 (annotated clause) + reserved "end" + return $ Case exp alts + +clause :: Parser Alt +clause = do pat <- patterns + g <- guard + symbol "->" + exp <- expression + return $ Alt pat g exp + +patterns :: Parser Pats +patterns = liftM Pat pattern <|> + liftM Pats (angles $ commaSep pattern) + +pattern :: Parser Pat +pattern = liftM PAlias (try alias) {- because of variable -} <|> liftM PVar variable <|> + liftM PLit (try literal) {- because of nil -} <|> liftM PTuple (tuple pattern) <|> + liftM PList (elist pattern) <|> liftM PBinary (ebinary pattern) + +alias :: Parser Alias +alias = do v <- variable + symbol "=" + p <- pattern + return $ Alias v p + +guard :: Parser Guard +guard = do reserved "when" + e <- expression + return $ Guard e + +elet :: Parser Exp +elet = do reserved "let" + vars <- variables + symbol "=" + e1 <- expression + symbol "in" + e2 <- expression + return $ Let (vars,e1) e2 + +variables :: Parser [Var] +variables = do { v <- variable; return [v]} <|> (angles $ commaSep variable) + +lambda :: Parser Exp +lambda = do reserved "fun" + vars <- parens $ commaSep variable + symbol "->" + expr <- expression + return $ Lambda vars expr + +letrec :: Parser Exp +letrec = do reserved "letrec" + defs <- many fundef + reserved "in" + e <- expression + return $ LetRec defs e + +elist :: Parser a -> Parser (List a) +elist a = brackets $ list a + +list :: Parser a -> Parser (List a) +list elem = do elems <- commaSep1 elem + option (L elems) (do symbol "|" + t <- elem + return $ LL elems t) + +modcall :: Parser Exp +modcall = do reserved "call" + e1 <- expression + symbol ":" + e2 <- expression + eN <- parens $ commaSep expression + return $ ModCall (e1, e2) eN + +op :: Parser Exp +op = do reserved "primop" + a <- atom + e <- parens $ commaSep expression + return $ Op a e + +receive :: Parser Exp +receive = do reserved "receive" + alts <- many $ annotated clause + to <- timeout + return $ Rec alts to + +timeout :: Parser TimeOut +timeout = do reserved "after" + e1 <- expression + symbol "->" + e2 <- expression + return $ TimeOut e1 e2 + +eseq :: Parser Exp +eseq = do reserved "do" + e1 <- expression + e2 <- expression + return $ Seq e1 e2 + +etry :: Parser Exp +etry = do reserved "try" + e1 <- expression + reserved "of" + v1 <- variables + symbol "->" + e2 <- expression + reserved "catch" + v2 <- variables + symbol "->" + e3 <- expression + return $ Try e1 (v1,e1) (v2,e2) + +tuple :: Parser a -> Parser [a] +tuple elem = braces $ commaSep elem + +annotation :: Parser [Const] +annotation = do symbol "-|" + cs <- brackets $ many constant + return $ cs + +annotated :: Parser a -> Parser (Ann a) +annotated p = parens (do e <- p + cs <- annotation + return $ Ann e cs) + <|> + do e <- p + return $ Constr e + +lexer :: TokenParser () +lexer = makeTokenParser + (emptyDef { + -- commentStart = "", + -- commentEnd = "", + commentLine = "%", + -- nestedComments = True, + identStart = upper <|> char '_', + identLetter = namechar + -- opStart, + -- opLetter, + -- reservedNames, + -- reservedOpNames, + -- caseSensitive = True, + }) + +angles = Token.angles lexer +braces = Token.braces lexer +brackets = Token.brackets lexer +commaSep = Token.commaSep lexer +commaSep1 = Token.commaSep1 lexer +decimal = Token.decimal lexer +float = Token.float lexer +identifier = Token.identifier lexer +natural = Token.natural lexer +parens = Token.parens lexer +reserved = Token.reserved lexer +reservedOp = Token.reservedOp lexer +symbol = Token.symbol lexer +whiteSpace = Token.whiteSpace lexer + +runLex :: Show a => Parser a -> String -> IO () +runLex p file = do input <- readFile file + parseTest (do whiteSpace + x <- p + eof + return x) input + return () + +-- | Parse of a string, which should contain a complete CoreErlang module +parseModule :: String -> Either ParseError (Ann Module) +parseModule input = parse (do whiteSpace + x <- emodule + eof + return x) "" input diff --git a/Language/CoreErlang/Pretty.hs b/Language/CoreErlang/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/CoreErlang/Pretty.hs @@ -0,0 +1,421 @@ +----------------------------------------------------------------------------- +-- | +-- 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 : Henrique Ferreiro García +-- David Castro Pérez +-- 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) diff --git a/Language/CoreErlang/Syntax.hs b/Language/CoreErlang/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/CoreErlang/Syntax.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- | +-- 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 : Henrique Ferreiro García +-- David Castro Pérez +-- Stability : experimental +-- Portability : portable +-- +-- A suite of datatypes describing the abstract syntax of CoreErlang 1.0.3. +-- + +----------------------------------------------------------------------------- + +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 + +-- | 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) + +-- | This type is used to represent function names +data Function = Function (Atom,Integer) + deriving (Eq,Ord,Show) + +-- | A CoreErlang source module. +data Module + = Module Atom [Function] [(Atom,Const)] [FunDef] + deriving (Eq,Ord,Show) + +-- | This type is used to represent constants +data Const + = CLit Literal + | CTuple [Const] + | CList (List Const) + deriving (Eq,Ord,Show) + +-- | This type is used to represent lambdas +data FunDef + = FunDef (Ann Function) (Ann Exp) + deriving (Eq,Ord,Show) + +-- | /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) + +-- | CoreErlang expressions. +data Exps + = Exp (Ann Exp) -- ^ single expression + | Exps (Ann [Ann Exp]) -- ^ list of expressions + deriving (Eq,Ord,Show) + +-- | 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) + +-- | A bitstring. +data BitString a + = BitString a [Exps] + deriving (Eq,Ord,Show) + +-- | A list of expressions +data List a + = L [a] + | LL [a] a + deriving (Eq,Ord,Show) + +-- | An /alt/ in a @case@ expression +data Alt + = Alt Pats Guard Exps + deriving (Eq,Ord,Show) + +data Pats + = Pat Pat -- ^ single pattern + | Pats [Pat] -- ^ list of patterns + deriving (Eq,Ord,Show) + +-- | 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) + +-- | An alias, used in patterns +data Alias + = Alias Var Pat + deriving (Eq,Ord,Show) + +-- | A guarded alternative @when@ /exp/ @->@ /exp/. +-- The first expression will be Boolean-valued. +data Guard + = Guard Exps + deriving (Eq,Ord,Show) + +-- | The timeout of a receive expression +data TimeOut + = TimeOut Exps Exps + deriving (Eq,Ord,Show) + +-- | An annotation for modules, variables, ... +data Ann a + = Constr a -- ^ core erlang construct + | Ann a [Const] -- ^ core erlang annotated construct + deriving (Eq,Ord,Show) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/hcar/hcar.sty b/hcar/hcar.sty new file mode 100644 --- /dev/null +++ b/hcar/hcar.sty @@ -0,0 +1,183 @@ +\ProvidesPackage{hcar} + +\newif\ifhcarfinal +\hcarfinalfalse +\DeclareOption{final}{\hcarfinaltrue} +\ProcessOptions + +\RequirePackage{keyval} +\RequirePackage{color} +\RequirePackage{array} + +\ifhcarfinal + \RequirePackage[T1]{fontenc} + \RequirePackage{lmodern} + \RequirePackage{tabularx} + \RequirePackage{booktabs} + \RequirePackage{framed} + \RequirePackage[obeyspaces,T1]{url} + \RequirePackage + [bookmarks=true,colorlinks=true, + urlcolor=urlcolor, + linkcolor=linkcolor, + breaklinks=true, + pdftitle={Haskell Communities and Activities Report}]% + {hyperref} +\else + \RequirePackage[obeyspaces]{url} +\fi +\urlstyle{sf} + +\definecolor{urlcolor}{rgb}{0.1,0.3,0} +\definecolor{linkcolor}{rgb}{0.3,0,0} +\definecolor{shadecolor}{rgb}{0.9,0.95,1}%{0.98,1.0,0.95} +\definecolor{framecolor}{gray}{0.9} +\definecolor{oldgray}{gray}{0.7} + +\newcommand{\Contact}{\subsubsection*{Contact}} +\newcommand{\FurtherReading}{\subsubsection*{Further reading}} +\newcommand{\FuturePlans}{\subsubsection*{Future plans}} +\newcommand{\Separate}{\smallskip\noindent} +\newcommand{\FinalNote}{\smallskip\noindent} + +\newcommand{\urlpart}{\begingroup\urlstyle{sf}\Url} +\newcommand{\email}[1]{\href{mailto:\EMailRepl{#1}{ at }}{$\langle$\urlpart{#1}$\rangle$}} +\newcommand{\cref}[1]{($\rightarrow\,$\ref{#1})} + +\ifhcarfinal + \let\hcarshaded=\shaded + \let\endhcarshaded=\endshaded +\else + \newsavebox{\shadedbox} + \newlength{\shadedboxwidth} + \def\hcarshaded + {\begingroup + \setlength{\shadedboxwidth}{\linewidth}% + \addtolength{\shadedboxwidth}{-2\fboxsep}% + \begin{lrbox}{\shadedbox}% + \begin{minipage}{\shadedboxwidth}\ignorespaces} + \def\endhcarshaded + {\end{minipage}% + \end{lrbox}% + \noindent + \colorbox{shadecolor}{\usebox{\shadedbox}}% + \endgroup} +\fi + +\ifhcarfinal + \newenvironment{hcartabularx} + {\tabularx{\linewidth}{l>{\raggedleft}X}} + {\endtabularx} +\else + \newenvironment{hcartabularx} + {\begin{tabular}{@{}m{.3\linewidth}@{}>{\raggedleft}p{.7\linewidth}@{}}} + {\end{tabular}} +\fi + +\ifhcarfinal + \let\hcartoprule=\toprule + \let\hcarbottomrule=\bottomrule +\else + \let\hcartoprule=\hline + \let\hcarbottomrule=\hline +\fi + +\define@key{hcarentry}{chapter}[]{\let\level\chapter} +\define@key{hcarentry}{section}[]{\let\level\section} +\define@key{hcarentry}{subsection}[]{\let\level\subsection} +\define@key{hcarentry}{subsubsection}[]{\let\level\subsubsection} +\define@key{hcarentry}{level}{\let\level=#1} +%\define@key{hcarentry}{label}{\def\entrylabel{\label{#1}}} +\define@key{hcarentry}{new}[]% + {\let\startnew=\hcarshaded\let\stopnew=\endhcarshaded + \def\startupdated{\let\orig@addv\addvspace\let\addvspace\@gobble}% + \def\stopupdated{\let\addvspace\orig@addv}} +\define@key{hcarentry}{old}[]{\def\normalcolor{\color{oldgray}}\color{oldgray}}% +\define@key{hcarentry}{updated}[]% + {\def\startupdated + {\leavevmode\let\orig@addv\addvspace\let\addvspace\@gobble\hcarshaded}% + \def\stopupdated{\endhcarshaded\let\addvspace\orig@addv}} + +\def\@makeheadererror{\PackageError{hcar}{hcarentry without header}{}} + +\newenvironment{hcarentry}[2][]% +{\let\level\subsection + \let\startupdated=\empty\let\stopupdated=\empty + \let\startnew=\empty\let\stopnew=\empty +%\let\entrylabel=\empty + \global\let\@makeheaderwarning\@makeheadererror + \setkeys{hcarentry}{#1}% + \startnew\startupdated + \level{#2}% + % test: + \global\let\@currentlabel\@currentlabel +%\stopupdated + \let\report@\empty + \let\groupleaders@\empty + \let\members@\empty + \let\contributors@\empty + \let\participants@\empty + \let\developers@\empty + \let\maintainer@\empty + \let\status@\empty + \let\release@\empty + \let\portability@\empty + \let\entry@\empty}% +{\stopnew\@makeheaderwarning}% + +\renewcommand{\labelitemi}{$\circ$} +\settowidth{\leftmargini}{\labelitemi} +\addtolength{\leftmargini}{\labelsep} + +\newcommand*\MakeKey[2]% + {\expandafter\def\csname #1\endcsname##1% + {\expandafter\def\csname #1@\endcsname{\Key@{#2}{##1}}\ignorespaces}} +\MakeKey{report}{Report by:} +\MakeKey{status}{Status:} +\MakeKey{groupleaders}{Group leaders:} +\MakeKey{members}{Members:} +\MakeKey{contributors}{Contributors:} +\MakeKey{participants}{Participants:} +\MakeKey{developers}{Developers:} +\MakeKey{maintainer}{Maintainer:} +\MakeKey{release}{Current release:} +\MakeKey{portability}{Portability:} +\MakeKey{entry}{Entry:} + +\newcommand\Key@[2]{#1 & #2\tabularnewline} + +\newcommand\makeheader +{\smallskip + \begingroup + \sffamily + \small + \noindent + \let\ohrule\hrule + \def\hrule{\color{framecolor}\ohrule}% + \begin{hcartabularx} + \hline + \report@ + \groupleaders@ + \members@ + \participants@ + \developers@ + \contributors@ + \maintainer@ + \status@ + \release@ + \portability@ + \hcarbottomrule + \end{hcartabularx} + \endgroup + \stopupdated + \global\let\@makeheaderwarning\empty + \@afterindentfalse + \@xsect\smallskipamount} + +% columns/linebreaks, interchanged +\newcommand\NCi{&\let\NX\NCii}% +\newcommand\NCii{&\let\NX\NL}% +\newcommand\NL{\\\let\NX\NCi}% +\let\NX\NCi +\newcommand\hcareditor[1]{ (ed.)&\\} +\newcommand\hcarauthor[1]{#1\NX}% diff --git a/hcar/template.tex b/hcar/template.tex new file mode 100644 --- /dev/null +++ b/hcar/template.tex @@ -0,0 +1,31 @@ +\documentclass{article} + +\usepackage{hcar} + +\begin{document} + +\begin{hcarentry}{CoreErlang} +\report{Henrique Ferreiro Garc\'{i}a} +\participants{David Castro P\'{e}rez} +\status{Parses and pretty-prints all of Core Erlang} +\makeheader + +CoreErlang is a haskell library which consists on a parser and +pretty-printer for the intermediate language used by Erlang. 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. + +It is able to parse and pretty print all of Core Erlang. Remaining work +includes customizing the pretty printer and refining the syntax interface. + +\FurtherReading + +\begin{itemize} +\item It can be downloaded from hackage at: +\item A darcs repository is available at: \url{http://code.haskell.org/CoreErlang} +\end{itemize} + +\end{hcarentry} + +\end{document}