diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Stefan Holdermans (Original author) +Atze Dijkstra (Maintainer) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +Copyright (c) 2008-2014 Utrecht University. All rights reserved. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/src/CCO/Component.hs b/src/CCO/Component.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Component.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Component +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : non-portable (uses CPP) +-- +-- An arrow for constructing and composing compiler components. +-- +------------------------------------------------------------------------------- + +module CCO.Component ( + -- * Components + Component -- abstract, instance: Arrow, ArrowChoice + + -- * Creating components + , component -- :: (a -> Feedback b) -> Component a b + , parser -- :: Lexer s -> Parser s a -> Component String a + + -- * Generic components + , printer -- :: Printable a => Component a String + + -- * Wrapping components + , ioWrap -- :: Component String String -> IO () +) where + +import CCO.Feedback (Feedback, runFeedback) +import CCO.Lexing (Lexer) +import CCO.Parsing (Parser, parse_) +import CCO.SourcePos (Source (Stdin)) +import CCO.Printing (Doc, render_, Printable (pp)) +import Control.Arrow (Arrow (..), ArrowChoice (..)) +import System.Exit (exitWith, ExitCode (ExitSuccess), exitFailure) +import System.IO (stderr) + +#ifdef CATEGORY +import Control.Category (Category) +import qualified Control.Category (Category (id, (.))) +#endif + +------------------------------------------------------------------------------- +-- Components +------------------------------------------------------------------------------- + +-- | The @Component@ arrow. +-- A @Component a b@ takes input of type @a@ to output of type @b@. +newtype Component a b = C {runComponent :: a -> Feedback b} + +#ifdef CATEGORY + +instance Category Component where + id = C return + C f . C g = C (\x -> g x >>= f) + +instance Arrow Component where + arr f = C (return . f) + first (C f) = C (\ ~(x, z) -> f x >>= \y -> return (y, z)) + +#else + +instance Arrow Component where + arr f = C (return . f) + C f >>> C g = C (\x -> f x >>= g) + first (C f) = C (\ ~(x, z) -> f x >>= \y -> return (y, z)) + +#endif + +instance ArrowChoice Component where + left (C f) = C (either (fmap Left . f) (return . Right)) + +------------------------------------------------------------------------------- +-- Creating components +------------------------------------------------------------------------------- + +-- | Creates a 'Component' from a 'Feedback' computation. +component :: (a -> Feedback b) -> Component a b +component = C + +-- | Creates a 'Component' from a 'Lexer' and a 'Parser'. +parser :: Lexer s -> Parser s a -> Component String a +parser l p = component (parse_ l p Stdin) + +------------------------------------------------------------------------------- +-- Generic components +------------------------------------------------------------------------------- + +-- | A 'Component' for rendering 'Printable's. +printer :: Printable a => Component a String +printer = arr (render_ 79 . pp) + +------------------------------------------------------------------------------- +-- Wrapping components +------------------------------------------------------------------------------- + +-- | Wraps a 'Component' into a program that provides it with input from the +-- standard input channel and relays its output to the standard output channel. +ioWrap :: Component String String -> IO () +ioWrap (C f) = do + input <- getContents + result <- runFeedback (f input) 1 1 stderr + case result of + Nothing -> exitFailure + Just output -> putStrLn output >> exitWith ExitSuccess diff --git a/src/CCO/Feedback.hs b/src/CCO/Feedback.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Feedback.hs @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Feedback +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A monad for keeping track of log, warning, and error messages. +-- +------------------------------------------------------------------------------- + +module CCO.Feedback ( + -- * Messages + Message (Log, Warning, Error) + , isError -- :: Message -> Bool + , fromMessage -- :: Message -> Doc + + -- * The Feedback monad + , Feedback -- abstract, instances: Functor, Monad + , trace -- :: Int -> String -> Feedback () + , trace_ -- :: String -> Feedback () + , warn -- :: Int -> String -> Feedback () + , warn_ -- :: String -> Feedback () + , errorMessage -- :: Doc -> Feedback () + , message -- :: Message -> Feedback () + , messages -- :: [Message] -> Feedback () + , wError -- :: Feedback a -> Feedback a + , succeeding -- :: Feedback a -> Bool + , failing -- :: Feedback a -> Bool + , runFeedback -- :: Feedback a -> Handle -> IO (Maybe a) +) where + +import CCO.Feedback.Message +import CCO.Printing (Doc, text) +import System.IO (Handle) + +------------------------------------------------------------------------------- +-- The Feedback monad +------------------------------------------------------------------------------- + +-- | The @Feedback@ monad. +-- Keeps track of 'Message's, failing if an 'Error' message is encountered. +data Feedback a + = Succeed [Message] a + | Fail [Message] + +instance Functor Feedback where + fmap f (Succeed msgs x) = Succeed msgs (f x) + fmap _ (Fail msgs) = Fail msgs + +instance Monad Feedback where + return x = Succeed [] x + + Succeed msgs x >>= f = case f x of + Succeed msgs' y -> Succeed (msgs ++ msgs') y + Fail msgs' -> Fail (msgs ++ msgs') + Fail msgs >>= _ = Fail msgs + + fail msg = Fail [Error (text msg)] + +-- | Issues a list of 'Message's. +-- Fails if the list contains an 'Error' message. +messages :: [Message] -> Feedback () +messages msgs | any isError msgs = Fail msgs + | otherwise = Succeed msgs () + +-- | Issues a 'Message'. +-- Fails if an 'Error' message is issued. +message :: Message -> Feedback () +message msg = messages [msg] + +-- | Issues an 'Error' message. +errorMessage :: Doc -> Feedback a +errorMessage doc = Fail [Error doc] + +-- | Issues a 'Log' message at a specified verbosity level containing a +-- specified text. +trace :: Int -> String -> Feedback () +trace v = message . Log v . text + +-- | Issues a 'Log' message at the default verbosity level 1 containing a +-- specified text. +trace_ :: String -> Feedback () +trace_ = trace 1 + +-- | Issues a 'Warning' message at a specified severity level containing a +-- specified text. +warn :: Int -> String -> Feedback () +warn w = message . Warning w . text + +-- | Issues a 'Warning' message at the default severity level 1 containing a +-- specified text. +warn_ :: String -> Feedback () +warn_ = warn 1 + +-- | Turns all 'Warning' messages into 'Error' messages. +wError :: Feedback a -> Feedback a +wError (Fail msgs) = Fail (fatalizeWarnings msgs) +wError (Succeed msgs x) = let msgs' = fatalizeWarnings msgs + in if any isError msgs' + then Fail msgs' + else Succeed msgs' x + +-- | Retrieves whether a 'Feedback' computation will succeed. +succeeding :: Feedback a -> Bool +succeeding (Succeed _ _) = True +succeeding _ = False + +-- | Retrieves whether a 'Feedback' computation will fail. +failing :: Feedback a -> Bool +failing (Fail _) = True +failing _ = False + +-- | Runs a 'Feedback' computation at a specified verbosity and severity level, +-- pretty printing messages onto a specified +-- 'Handle'. +runFeedback :: Feedback a -> Int -> Int -> Handle -> IO (Maybe a) +runFeedback (Succeed msgs x) v w h = do let msgs' = filterMessages v w msgs + putMessages h msgs' + return (Just x) +runFeedback (Fail msgs) v w h = do let msgs' = filterMessages v w msgs + putMessages h msgs' + return Nothing diff --git a/src/CCO/Feedback/Message.hs b/src/CCO/Feedback/Message.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Feedback/Message.hs @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Feedback.Message +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Log, warning, and error messages. +-- +------------------------------------------------------------------------------- + +module CCO.Feedback.Message ( + -- * Messages + Message (Log, Warning, Error) + , isError -- :: Message -> Bool + , fromMessage -- :: Message -> Doc + , fatalizeWarnings -- :: [Message] -> [Message] + , filterMessages -- :: Int -> Int -> [Message] -> [Message] + , putMessages -- :: Handle -> [Message] -> IO () +) where + +import CCO.Printing (Doc, render_, renderHeight_) +import System.IO (Handle, hPutStrLn) + +------------------------------------------------------------------------------- +-- Messages +------------------------------------------------------------------------------- + +-- | Type of messages. +-- Each @Message@ holds a pretty-printable document in which the text for the +-- message is stored. +data Message + = Log Int Doc -- ^ A log message at a specified verbosity level, the + -- default level being 1. + | Warning Int Doc -- ^ A warning message at a specified severity level, + -- the default level being 1. + | Error Doc -- ^ An error message. + +-- | Indicates whether a 'Message' is an 'Error' message. +isError :: Message -> Bool +isError (Error _) = True +isError _ = False + +-- | Retrieves the 'Doc' stored in a 'Message'. +fromMessage :: Message -> Doc +fromMessage (Log _ doc) = doc +fromMessage (Warning _ doc) = doc +fromMessage (Error doc) = doc + +-- | Turns 'Warning' messages into 'Error' messages. +fatalizeWarnings :: [Message] -> [Message] +fatalizeWarnings = map f + where + f (Warning _ doc) = Error doc + f msg = msg + +-- | Filters 'Message's that do not exceed specified verbosity and severity +-- levels. +filterMessages :: Int -> Int -> [Message] -> [Message] +filterMessages v w = filter p + where + p (Log v' _) = v' <= v + p (Warning w' _) = w' <= w + p _ = True + +-- | Pretty prints the 'Doc' stored in a 'Message' onto a 'Handle'. +putMessages :: Handle -> [Message] -> IO () +putMessages h = putMsgs + where + putMsgs [] = return () + putMsgs [msg] = hPutStrLn h (render_ 79 (fromMessage msg)) + putMsgs (msg : msgs) = do + let (s, height) = renderHeight_ 79 (fromMessage msg) + hPutStrLn h s + if height >= 0 then hPutStrLn h "" else return () + putMsgs msgs diff --git a/src/CCO/Lexing.hs b/src/CCO/Lexing.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Lexing.hs @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Lexing +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A library of lexer combinators that expose their functionality through an +-- 'Applicative' interface. +-- +------------------------------------------------------------------------------- + +module CCO.Lexing ( + -- * Lexers + Lexer -- abstract, instances: Functor, + -- Applicative, Alternative + , satisfy -- :: Lexer Char + , message -- :: String -> Lexer a + + -- * Derived lexers + , anyChar -- :: Lexer Char + , anyCharFrom -- :: [Char] -> Lexer Char + , anyCharBut -- :: [Char] -> Lexer Char + , range -- :: (Char, Char) -> Lexer Char + , notInRange -- :: (Char, Char) -> Lexer Char + , char -- :: Lexer Char + , string -- :: Lexer String + , space -- :: Lexer Char + , lower -- :: Lexer Char + , upper -- :: Lexer Char + , letter -- :: Lexer Char + , alpha -- :: Lexer Char + , alphaNum -- :: Lexer Char + , digit -- :: Lexer Char + , digit_ -- :: Lexer Int + , binDigit -- :: Lexer Char + , binDigit_ -- :: Lexer Int + , octDigit -- :: Lexer Char + , octDigit_ -- :: Lexer Int + , hexDigit -- :: Lexer Char + , hexDigit_ -- :: Lexer Int + + -- * Ignoring recognised input + , ignore -- :: Lexer a -> Lexer b + + -- * Symbols + , LexicalUnit (Token, Error, Msg) + , Symbols (Symbols) + + -- * Lexing + , lex -- :: Lexer a -> Source -> String -> + -- Symbols a + + -- * Utilities + , tokens -- :: Symbols a -> [(SourcePos, a)] + , tokens_ -- :: Symbols a -> [a] +) where + +import Prelude hiding (lex) +import CCO.SourcePos (Source, Pos (Pos, EOF), SourcePos (SourcePos)) +import Control.Applicative (Applicative (..), Alternative (..), (<$>)) +import Data.Char + +------------------------------------------------------------------------------- +-- Steps +------------------------------------------------------------------------------- + +-- | A @Steps@ represents the tokenisation associated with the recognition of +-- a (part of a) lexeme. +data Steps a = None -- ^ No tokenisation yet. + | Return a -- ^ Produces as a token a value of type @a@. + | Ignore -- ^ Produces a value of type @a@ but ignores it as + -- far as tokenisation is concerned. + -- (Typically used on lexemes that constitute + -- comments or whitespace.) + | Fail String -- ^ Fail with a specified error message. + +instance Functor Steps where + fmap _ None = None + fmap f (Return x) = Return (f x) + fmap _ Ignore = Ignore + fmap _ (Fail msg) = Fail msg + +instance Applicative Steps where + pure x = Return x + + (Fail msg) <*> _ = Fail msg + _ <*> (Fail msg) = Fail msg + None <*> _ = None + _ <*> None = None + Return f <*> Return x = Return (f x) + _ <*> _ = Ignore + +instance Alternative Steps where + empty = None + + steps@(Return _) <|> _ = steps + steps@Ignore <|> _ = steps + _ <|> steps@(Return _) = steps + _ <|> steps@Ignore = steps + None <|> steps = steps + steps <|> _ = steps + +------------------------------------------------------------------------------- +-- Lexers +------------------------------------------------------------------------------- + +-- | Type of lexers that produce tokens of type @a@. +data Lexer a = Trie (Steps a) [(Char -> Bool, Lexer (Char -> a))] + -- ^ A @Lexer@ consists of a @Steps@-component that represents + -- the tokenisation for the lexeme currently recognised and + -- a multi-mapping from characters to lexers that represent + -- the next state of the scanner. + +instance Functor Lexer where + fmap f (Trie steps edges) = + Trie (fmap f steps) [(p, fmap (f .) next) | (p, next) <- edges] + +instance Applicative Lexer where + pure x = Trie (pure x) [] + + Trie None edges <*> lexer = Trie None + [(p, flip <$> next <*> lexer) | (p, next) <- edges] + Trie (Fail msg) edges <*> lexer = Trie (Fail msg) + [(p, flip <$> next <*> lexer) | (p, next) <- edges] + Trie steps edges <*> lexer@(Trie steps' edges') = Trie (steps <*> steps') $ + [(p, smap ((.) <$> steps) next) | (p, next) <- edges'] ++ + [(p, flip <$> next <*> lexer) | (p, next) <- edges] + +instance Alternative Lexer where + empty = Trie empty [] + Trie steps edges <|> Trie steps' edges' = + Trie (steps <|> steps') (edges ++ edges') + +-- | Maps a tokenisation over a 'Lexer'. +smap :: Steps (a -> b) -> Lexer a -> Lexer b +smap steps (Trie steps' edges) = Trie (steps <*> steps') + [(p, smap ((.) <$> steps) next) | (p, next) <- edges] + +-- | A 'Lexer' that recognises any character that satisfies a specified +-- predicate. +satisfy :: (Char -> Bool) -> Lexer Char +satisfy p = Trie None [(p, Trie (Return id) [])] + +-- | A 'Lexer' that will produce a specified error message. +message :: String -> Lexer a +message msg = Trie (Fail msg) [] + +------------------------------------------------------------------------------- +-- Derived lexers +------------------------------------------------------------------------------- + +-- | The trivial 'Lexer' that recognises any character. +anyChar :: Lexer Char +anyChar = satisfy (const True) + +-- | A 'Lexer' that recognises any character that appears in a given list. +anyCharFrom :: [Char] -> Lexer Char +anyCharFrom cs = satisfy (`elem` cs) + +-- | A 'Lexer' that recognises any character that does not appear in a given +-- list. +anyCharBut :: [Char] -> Lexer Char +anyCharBut tabus = satisfy (`notElem` tabus) + +-- | A 'Lexer' that recognises any character that appears in a given range. +-- More efficent than @\\(low, up) -> anyCharFrom [low .. up]@. +range :: (Char, Char) -> Lexer Char +range (low, up) = satisfy (\c -> c >= low && c <= up) + +-- | A 'Lexer' that recognises any character that does not appear in a given +-- range. +notInRange :: (Char, Char) -> Lexer Char +notInRange (low, up) = satisfy (\c -> c < low || c > up) + +-- | A 'Lexer' that recognises a specified character. +char :: Char -> Lexer Char +char c = satisfy (== c) + +-- | A 'Lexer' that recognises a specified 'String'. +string :: String -> Lexer String +string [] = pure [] +string (c : cs) = (:) <$> char c <*> string cs + +-- | A 'Lexer' that recognises a whitespace character +space :: Lexer Char +space = satisfy isSpace + +-- | A 'Lexer' that recognises lower-case alphabetic characters. +lower :: Lexer Char +lower = satisfy isLower + +-- | A 'Lexer' that recognises upper-case or title-case alphabetic characters. +upper :: Lexer Char +upper = satisfy isUpper + +-- | A 'Lexer' that recognises alphabetic characters. Equivalent to 'alpha'. +letter :: Lexer Char +letter = alpha + +-- | A 'Lexer' that recognises alphabetic characters. Equivalet to 'letter'. +alpha :: Lexer Char +alpha = satisfy isAlpha + +-- | A 'Lexer' that recognises alphabetic or numeric characters. +alphaNum :: Lexer Char +alphaNum = satisfy isAlphaNum + +-- | A 'Lexer' that recognises a digit. +digit :: Lexer Char +digit = satisfy isDigit + +-- | A 'Lexer' that recognises a digit and tokenises it as an 'Int'. +digit_ :: Lexer Int +digit_ = (\c -> ord c - ordZero) <$> digit + +-- | A 'Lexer' that recognises a binary digit. +binDigit :: Lexer Char +binDigit = range ('0', '1') + +-- | A 'Lexer' that recognises a binary digit and tokenises it as an 'Int'. +binDigit_ :: Lexer Int +binDigit_ = (\c -> ord c - ordZero) <$> binDigit + +-- | A 'Lexer' that recognises an octal digit. +octDigit :: Lexer Char +octDigit = satisfy isOctDigit + +-- | A 'Lexer' that recognises an octal digit and tokenises it as an 'Int'. +octDigit_ :: Lexer Int +octDigit_ = (\c -> ord c - ordZero) <$> octDigit + +-- | A 'Lexer that recognises a hexedecimal digit. +hexDigit :: Lexer Char +hexDigit = satisfy isHexDigit + +-- | A 'Lexer' that recognises a hexadecimal digit and tokenises it as an +-- 'Int'. +hexDigit_ :: Lexer Int +hexDigit_ = (\c -> ord c - ordZero) <$> digit <|> + (\c -> 10 + (ord c - ordLowerA)) <$> range ('a', 'f') <|> + (\c -> 10 + (ord c - ordUpperA)) <$> range ('A', 'F') + +------------------------------------------------------------------------------- +-- Ignoring recognised input +------------------------------------------------------------------------------- + +-- | Produces a 'Lexer' that recognises the same inputs as a given underlying +-- 'Lexer', but that does not result in any tokenisation. +-- +-- The input recognised by a 'Lexer' constructed with @ignore@ is simply +-- ignored when the 'Lexer' is used to turn a stream of characters into a +-- stream of 'LexicalUnit's. +-- +-- Mainly used to suppress the generation of tokens for lexemes that constitute-- lexical units like comments and whitespace. + +ignore :: Lexer a -> Lexer b +ignore = smap Ignore + +------------------------------------------------------------------------------- +-- Symbols +------------------------------------------------------------------------------- + +-- | The type of lexical units. +data LexicalUnit a + = Token a Pos String String -- ^ A tokenised lexeme: its token, its + -- position, the characters it consists + -- of, and its its trailing characters in + -- the input stream. + | Error Pos String String -- ^ An invalid lexeme: its position, the + -- characters it consists of, and its + -- trailing characters in the input + -- stream. + | Msg String Pos String String -- ^ An invalid lexeme, labeled by a custom + -- error message: the message, its + -- position, the characters it consists + -- of, and its trailing characters in the + -- input stream. + +-- | The type of streams of symbols described by tokens of type 'a'. +data Symbols a = Symbols Source [LexicalUnit a] + +------------------------------------------------------------------------------- +-- Lexing +------------------------------------------------------------------------------- + +-- | A @Scan@: an accumulator for the input recognised, a tokenisation for the +-- input recognised, the current position, and the remaining input. +type Scan a = (String -> String, Steps a, Pos, String) + +-- | Scanner: takes a 'Lexer', an input position, and an input stream and then +-- produces a 'Scan' for the next lexeme. +scan :: Lexer a -> Pos -> String -> Scan a +scan (Trie steps edges) pos input = (id, steps, pos, input) `sor` consume input + where + consume [] = (id, None, pos, input) + consume (c : cs) = + let lexer = choice [next | (p, next) <- edges, p c] + (acc, steps', pos', input') = + scan (lexer <*> pure c) (incrPos c pos) cs + in ((c :) . acc, steps', pos', input') + +-- | Picks the \"best\" of two 'Scan's, favouring the second over the first, +-- except when the second does not allow any tokenisation. +sor :: Scan a -> Scan a -> Scan a +sor scn (_, None, _, _) = scn +sor _ scn = scn + +-- | Runs a lexer on a specified input stream. +lex :: Lexer a -> Source -> String -> Symbols a +lex lexer src = let initpos = initialPos + in Symbols src . tokenise initpos id initpos + where + tokenise errpos prefix pos input = + let sentinel = case prefix "" of + [] -> id + lexeme -> (Error errpos lexeme input :) + in case scan lexer pos input of + (_, None, _, []) -> sentinel [] + (acc, None, pos', c : input') -> tokenise errpos (prefix . (c :)) + (incrPos c pos') input' + (acc, Return x, pos', input') -> sentinel $ + Token x pos (acc "") input' : + tokenise pos' id pos' input' + (acc, Fail msg, pos', input') -> Msg msg errpos (acc "") input' : + tokenise pos' id pos' input' + (_, _, pos', input') -> sentinel + (tokenise pos' id pos' input') + +------------------------------------------------------------------------------- +-- Source positions +------------------------------------------------------------------------------- + +-- | Retrieves the first position in an input stream. +initialPos :: Pos +initialPos = Pos 1 1 + +-- | Increments a 'Pos' based on the character consumed. +-- If a newline character is consumed, the line number is incremented and the +-- column number is reset to 1; for any other character, the line number is +-- kept unchanged and the column number is incremented by 1. +-- Fails if an attempt is made to increment an 'EOF'-value. +incrPos :: Char -> Pos -> Pos +incrPos '\n' (Pos line column) = Pos (line + 1) 1 +incrPos _ (Pos line column) = Pos line (column + 1) + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | The 'ord' of '\'0\''. +ordZero :: Int +ordZero = ord '0' + +-- | The 'ord' of '\'a\''. +ordLowerA :: Int +ordLowerA = ord 'a' + +-- | The 'ord' of '\'A\''. +ordUpperA :: Int +ordUpperA = ord 'A' + +-- | Combines multiple 'Alternative's by means of '<|>'. +choice :: Alternative f => [f a] -> f a +choice [] = empty +choice [x] = x +choice xs = foldr1 (<|>) xs + +-- | Retrieves all tokens together with their source positions from a list of +-- 'Symbols'. +tokens :: Symbols a -> [(SourcePos, a)] +tokens (Symbols src units) = + [(SourcePos src pos, x) | Token x pos _ _ <- units] + +-- | Retrieves all tokens from a list of 'Symbols'. +tokens_ :: Symbols a -> [a] +tokens_ (Symbols _ units) = [x | Token x _ _ _ <- units] diff --git a/src/CCO/Parsing.hs b/src/CCO/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Parsing.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE Rank2Types #-} + +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Parsing +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : non-portable (uses rank-2 types) +-- +-- A library of parser combinators that expose their functionality through an +-- 'Applicative' interface. +-- +-- Based on work by Doaitse Swierstra. +-- +------------------------------------------------------------------------------- + +module CCO.Parsing ( + -- * Symbols + Symbol (describe) + + -- * Parsers + , Parser -- abstract, instances: Functor, Applicative, + -- Alternative + , satisfy -- :: Symbol s => (s -> Bool) -> Parser s s + , eof -- :: Symbol s => Parser s () + , sourcePos -- :: Parser s SourcePos + , lexeme -- :: Parser s String + , () -- :: Parser s a -> String -> Parser s a + + -- * Derived combinators + , choice -- :: Symbol s => [Parser s a] -> Parser s a + , opt -- :: Symbol s => Parser s a -> a -> Parser s a + , chainl -- :: Symbol s => + -- Parser s (a -> a -> a) -> Parser s a -> + -- Parser s a + , chainr -- :: Symbol s => + -- Parser s (a -> a -> a) -> Parser s a -> + -- Parser s a + , manySepBy -- :: Symbol s => + -- Parser s b -> Parser s a -> Parser s [a] + , someSepBy -- :: Symbol s => + -- Parser s b -> Parser s a -> Parser s [a] + + -- * Parsing + , parse -- :: Parser s a -> Symbols s -> + -- Feedback (a, Symbols s) + , parse_ -- :: Lexer s -> Parser s a -> Source -> String -> + -- Feedback a +) where + +import CCO.Feedback (Feedback, errorMessage) +import CCO.Lexing hiding (satisfy) +import CCO.SourcePos (Source (..), Pos (..), SourcePos (..)) +import CCO.Printing hiding (empty) +import qualified CCO.Printing as P (empty) +import Control.Applicative +import Data.Function (on) +import Data.List (nub) +import Prelude hiding (lex) + +------------------------------------------------------------------------------- +-- Symbols +------------------------------------------------------------------------------- + +-- | The class of types that describe input symbols. +-- +-- A minimal complete definition must supply the method @describe@. +class Symbol s where + describe :: s -> String -> String + -- ^ Retrieves a textual description from a value that describes a symbol and + -- the lexeme that constitutes the symbol. + +instance Symbol Char where + describe _ = show + +------------------------------------------------------------------------------- +-- Steps +------------------------------------------------------------------------------- + +-- | Describes the construction of a value produced by a 'Parser'. +data Steps a + = Done a + -- ^ The actual construction of a value. + | Fail SourcePos (Maybe String) ([String] -> [String]) + -- ^ Failure to construct a value. + -- Holds the position at which parsing failed, optionally a description + -- of the unexpected symbol that was encountered at that postition, + -- and an accumulator for descriptions of the terminals that were + -- actually expected. + | LexFail (Maybe String) SourcePos String + -- ^ Failure to construct a value because of a lexical error. + -- Holds an optional error message, the position of the erroneous lexeme + -- and the lexeme itself. + | Step (Steps a) + -- ^ A single step in the construction of a value. + +-- | Selects the best of two value constructions. +-- If both alternatives actually construct a value, the shortest construction +-- is selected; if both constructions require the same amount of steps, the +-- first takes precedence over the second. +best :: Steps a -> Steps a -> Steps a +best steps@(LexFail _ _ _) _ = steps +best _ steps@(LexFail _ _ _) = steps +best (Fail srcpos unexp acc) (Fail _ _ acc') + = Fail srcpos unexp (acc . acc') +best (Fail _ _ _) steps = steps +best steps (Fail _ _ _) = steps +best steps@(Done _) _ = steps +best _ steps@(Done _) = steps +best (Step steps) (Step steps') = Step (best steps steps') + +-- | Actually tries to constucts a value. +eval :: Steps a -> Feedback a +eval (Done x) = return x +eval (Fail srcpos unexp acc) = errorMessage . pp $ + UnexpectedSymbol srcpos unexp (nub (acc [])) +eval (LexFail mmsg srcpos lx) = errorMessage (pp (LexicalError mmsg srcpos lx)) +eval (Step steps) = eval steps + +------------------------------------------------------------------------------- +-- Parsers +------------------------------------------------------------------------------- + +infixl 2 + +-- | The type of parsers that consume symbols described by tokens of type @s@ +-- and produces values of type @a@. +newtype Parser s a + = P {unP :: forall h r. + ((h, a) -> Maybe ([String] -> [String]) -> + Symbols s -> Steps r) -> -- continuation + h -> -- previous values + Maybe ([String] -> [String]) -> -- productions + Symbols s -> -- input + Steps r + } + -- ^ Takes a continuation, a stack of previously produced values, an + -- optional accumulator for textual descriptions of associated grammar + -- productions, and an input stream. + -- + -- Note: the stack and result types are existentially quantified, which + -- makes that P has a rank-2 type. + +instance Functor (Parser s) where + fmap f (P p) = P (\k -> p (\(h, x) -> k (h, f x))) + +instance Applicative (Parser s) where + pure x = P (\k h -> k (h, x)) + P p <*> P q = P (\k -> p (q (\((h, f), x) -> k (h, f x)))) + +instance Symbol s => Alternative (Parser s) where + empty = P $ \_ _ macc (Symbols src units) -> case units of + [] -> Fail (SourcePos src EOF) Nothing + (maybe id id macc) + Token s pos lx _ : _ -> Fail (SourcePos src pos) + (Just (describe s lx)) (maybe id id macc) + Error pos lx _ : _ -> LexFail Nothing (SourcePos src pos) lx + Msg msg pos lx _ : _ -> LexFail (Just msg) (SourcePos src pos) lx + + P p <|> P q = P (\k h macc syms -> p k h macc syms `best` q k h macc syms) + +-- | Produces a 'Parser' that recognises a single symbol satisfying a given +-- predicate. +satisfy :: Symbol s => (s -> Bool) -> Parser s s +satisfy test = P p + where + p _ _ macc (Symbols src []) + = Fail (SourcePos src EOF) Nothing (maybe id id macc) + p k h macc (Symbols src (Token s pos lx _ : units)) + | test s = Step (k (h, s) Nothing (Symbols src units)) + | otherwise = Fail (SourcePos src pos) (Just (describe s lx)) + (maybe id id macc) + p _ _ _ (Symbols src (Error pos lx _ : _)) + = LexFail Nothing (SourcePos src pos) lx + p _ _ _ (Symbols src (Msg msg pos lx _ : _)) + = LexFail (Just msg) (SourcePos src pos) lx + +-- | A 'Parser' that recognises the end of input. +eof :: Symbol s => Parser s () +eof = P p + where + p k h _ syms@(Symbols _ []) + = Step (k (h, ()) Nothing syms) + p _ _ _ (Symbols src (Token s pos lx _ : _)) + = Fail (SourcePos src pos) (Just (describe s lx)) ("end of input" :) + p _ _ _ (Symbols src (Error pos lx _ : _)) + = LexFail Nothing (SourcePos src pos) lx + p _ _ _ (Symbols src (Msg msg pos lx _ : _)) + = LexFail (Just msg) (SourcePos src pos) lx + +-- | A 'Parser' that produces the 'SourcePos' of the next lexeme in the input +-- (without consuming the associated symbol). +sourcePos :: Parser s SourcePos +sourcePos = P p + where + p k h macc syms@(Symbols src []) + = k (h, SourcePos src EOF) macc syms + p k h macc syms@(Symbols src (Token _ pos _ _ : _)) + = k (h, SourcePos src pos) macc syms + p k h macc syms@(Symbols src (Error pos _ _ : _)) + = k (h, SourcePos src pos) macc syms + p k h macc syms@(Symbols src (Msg _ pos _ _ : _)) + = k (h, SourcePos src pos) macc syms + +-- | A 'Parser' that produces the next lexeme in the input (without consuming +-- the associated symbol). +-- Fails if the end of input has been reached. +lexeme :: Parser s String +lexeme = P p + where + p k h _ (Symbols src []) + = Fail (SourcePos src EOF) Nothing ("any symbol" :) + p k h macc syms@(Symbols _ (Token _ _ lx _ : _)) = k (h, lx) macc syms + p k h macc syms@(Symbols _ (Error _ lx _ : _ )) = k (h, lx) macc syms + p k h macc syms@(Symbols _ (Msg _ _ lx _ : _)) = k (h, lx) macc syms + +-- | Labels a 'Parser' with a description of the grammar production it is +-- associated with. +-- Used to produce more informative error messages. +() :: Parser s a -> String -> Parser s a +P p prod = P q where + q k h Nothing = p (\h macc' syms -> k h macc' syms) h (Just (prod :)) + q k h macc = p (\h macc' syms -> k h macc' syms) h macc + +------------------------------------------------------------------------------- +-- Derived combinators +------------------------------------------------------------------------------- + +infixl 3 `opt` + +-- | Produces a 'Parser' that may use any 'Parser' from a given list to +-- parse its input. +choice :: Symbol s => [Parser s a] -> Parser s a +choice [] = empty +choice [parser] = parser +choice parsers = foldr1 (<|>) parsers + +-- | Produces a 'Parser' that tries to parse its input with a given argument +---'Parser',producing a specified default value if the argument 'Parser' fails. +opt :: Symbol s => Parser s a -> a -> Parser s a +opt parser x = parser <|> pure x + +-- | Produces a 'Parser' that parses one or more elements chained by a +-- left-associative operator. +chainl :: Symbol s => Parser s (a -> a -> a) -> Parser s a -> Parser s a +chainl op elem = foldl (flip ($)) <$> elem <*> many (flip <$> op <*> elem) + +-- | Produces a 'Parser' that parses one or more elements chained by a +-- right-associative operator. +chainr :: Symbol s => Parser s (a -> a -> a) -> Parser s a -> Parser s a +chainr op elem = parser + where + parser = elem <**> (flip <$> op <*> parser `opt` id) + +-- | Produces a 'Parser' that parses zero or more elements separated by +-- specified separator. +manySepBy :: Symbol s => Parser s b -> Parser s a -> Parser s [a] +manySepBy sep elem = (:) <$> elem <*> many (sep *> elem) <|> pure [] + +-- | Produces a 'Parser' that parses one or more elements separated by +-- specified separator. +someSepBy :: Symbol s => Parser s b -> Parser s a -> Parser s [a] +someSepBy sep elem = (:) <$> elem <*> many (sep *> elem) + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- | Uses a specified 'Parser' to try and parse 'Symbols'. +-- Produces,if successful, a result and any remaining 'Symbols'. +parse :: Parser s a -> Symbols s -> Feedback (a, Symbols s) +parse (P p) = eval . p (\(_, x) _ syms -> Done (x, syms)) () Nothing + +-- | Uses a specified 'Lexer' and 'Parser' to perform syntactic analysis on +-- an input stream. +parse_ :: Lexer s -> Parser s a -> Source -> String -> Feedback a +parse_ lexer parser src = fmap fst . parse parser . lex lexer src + +------------------------------------------------------------------------------- +-- Diagnostics +------------------------------------------------------------------------------- + +-- | Diagnosis of why parsing failed. +data Diagnosis + = LexicalError (Maybe String) SourcePos String + -- ^ Indicates that parsing failed because of a lexical error. + -- Holds an optional error message, the position at which the error + -- occurred and the erroneous lexeme. + | UnexpectedSymbol SourcePos (Maybe String) [String] + -- ^ Indicates that parsing failed because an expected symbol (or the end + -- of input) was encountered. + -- Holds the position at which parsing failed, optionally a description + -- of the unexpected symbol that was encounterd at that position and a + -- list of descriptions of the phrases that were actually expected. + +instance Printable Diagnosis where pp = ppDiagnosis + +------------------------------------------------------------------------------- +-- Pretty printing diagnoses +------------------------------------------------------------------------------- + +-- | Pretty prints a 'Diagnosis'. +ppDiagnosis :: Diagnosis -> Doc + +ppDiagnosis (LexicalError Nothing srcpos lx) + = above [ppHeader, text " ", ppUnexpected] + where + ppHeader = wrapped $ + describeSourcePos srcpos ++ ": Lexical error." + ppUnexpected = text "? unexpected : " >|< text lx + +ppDiagnosis (LexicalError (Just msg) srcpos _) + = wrapped (describeSourcePos srcpos ++ ": Lexical error: " ++ msg ++ ".") + +ppDiagnosis (UnexpectedSymbol srcpos unexp exp) + = above [ppHeader, text " ", ppUnexpected, ppExpected] + where + ppHeader = wrapped $ + describeSourcePos srcpos ++ ": Syntax error." + ppUnexpected = text "? unexpected : " >|< + wrapped (describeUnexpected unexp) + ppExpected | null exp = P.empty + | otherwise = text "? expected : " >|< + wrapped (disjunction exp) + +-- | Retrieves a textual description of a 'SourcePos'. +describeSourcePos :: SourcePos -> String +describeSourcePos (SourcePos (File file) (Pos ln col)) + = file ++ + ":line " ++ show ln ++ + ":column " ++ show col +describeSourcePos (SourcePos (File file) EOF) = file ++ + ":" +describeSourcePos (SourcePos Stdin (Pos ln col)) = "line " ++ show ln ++ + ":column " ++ show col +describeSourcePos (SourcePos Stdin EOF) = "" + +-- | Retrieves a textual description of an unexpected symbol. +describeUnexpected :: Maybe String -> String +describeUnexpected Nothing = "end of input" +describeUnexpected (Just sym) = sym + +-- | Takes a non-empty list of textual items and produces a text that +-- expresses their disjunction: \", , ..., or \". +disjunction :: [String] -> String +disjunction [x] = x +disjunction [x, y] = x ++ " or " ++ y +disjunction [x, y, z] = x ++ ", " ++ y ++ ", or " ++ z +disjunction (x : xs) = x ++ ", " ++ disjunction xs diff --git a/src/CCO/Printing.hs b/src/CCO/Printing.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Printing.hs @@ -0,0 +1,468 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Printing +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A combinator library for pretty printing. +-- +-- Inspired by +-- +-- * S. Doaitse Swierstra, Pablo R. Azero Alcocer, and Joao Saraiva. +-- Designing and implementing combinator languages. +-- In S. Doaitse Swierstra and Pedro Rangel Henriques, and Jose Nuno +-- Oliveira, editors, /Advanced Functional Programming, Third International/ +-- /School, Braga, Portugal, September 12-19, 1998, Revised Lectures/, volume +-- 1608 of /Lecture Notes in Computer Science/, pages 150-206. +-- Springer-Verlag, 1999. +-- +------------------------------------------------------------------------------- + +module CCO.Printing ( + -- * Abstract document type + Doc -- abstract + , isEmpty -- :: Doc -> Bool + + -- * Primitive document constructors + , empty -- :: Doc + , text -- :: String -> Doc + , wrapped -- :: String -> Doc + + -- * Elementary document combinators + , indent -- :: Int -> Doc -> Doc + , (>-<) -- :: Doc -> Doc -> Doc + , above -- :: [Doc] -> Doc + , (>|<) -- :: Doc -> Doc -> Doc + , besides -- :: [Doc] -> Doc + + -- * Parallelisation + , (>//<) -- :: Doc -> Doc -> Doc + , split -- :: [Doc] -> Doc + , join -- :: Doc -> Doc + , (>^<) -- :: Doc -> Doc -> Doc + , choose -- :: [Doc] -> Doc + + -- * Punctuation + , space -- :: Doc + , period -- :: Doc + , comma -- :: Doc + , semicolon -- :: Doc + , colon -- :: Doc + , sepBy -- :: [Doc] -> Doc + , (>#<) -- :: Doc -> Doc -> Doc + , lparen, rparen -- :: Doc + , lbracket, rbracket -- :: Doc + , lbrace, rbrace -- :: Doc + , langle, rangle -- :: Doc + , enclose -- :: Doc -> Doc -> Doc -> Doc + , parens -- :: Doc -> Doc + , brackets -- :: Doc -> Doc + , braces -- :: Doc -> Doc + , angles -- :: Doc -> Doc + + -- * Colours + , black -- :: Doc -> Doc + , red -- :: Doc -> Doc + , green -- :: Doc -> Doc + , blue -- :: Doc -> Doc + , yellow -- :: Doc -> Doc + , magenta -- :: Doc -> Doc + , cyan -- :: Doc -> Doc + , white -- :: Doc -> Doc + + -- * Rendering + , render -- :: Int -> Doc -> Maybe String + , render_ -- :: Int -> Doc -> String + , renderHeight -- :: Int -> Doc -> Maybe (String, Int) + , renderHeight_ -- :: Int -> Doc -> (String, Int) + , renderIO -- :: Int -> Doc -> Maybe (IO ()) + , renderIO_ -- :: Int -> Doc -> IO () + , renderIOHeight -- :: Int -> Doc -> Maybe (IO (), Int) + , renderIOHeight_ -- :: Int -> Doc -> (IO (), Int) + + -- * The class Printable + , Printable (..) + + -- * Printing showables + , showable -- :: Show a => a -> Doc + ) where + +import CCO.Printing.Colour (Colour (..)) +import CCO.Printing.Doc (Doc (..), isEmpty) +import CCO.Printing.Printer (Printer (height), printToString, printToIO) +import qualified CCO.Printing.Rendering as R (render) +import Control.Arrow ((&&&)) +import Data.Maybe (catMaybes) + +------------------------------------------------------------------------------- +-- Primitive document constructors +------------------------------------------------------------------------------- + +-- | The empty document. +-- Left and right unit of '>-<' and '>|<'. +empty :: Doc +empty = Empty + +-- | @text txt@ produces a document containing the text @txt@. +text :: String -> Doc +text = foldr Above Empty . map Text . lines + +-- | @wrapped txt@ produces a document containing the text @txt@, possibly +-- wrapping its contents to fit the available space +wrapped :: String -> Doc +wrapped = foldr Above Empty . map Wrapped . lines + +------------------------------------------------------------------------------- +-- Document combinators +------------------------------------------------------------------------------- + +infixr 3 >|< +infixr 2 >-< + +-- | Indents a document by a given amount of space. +indent :: Int -> Doc -> Doc +indent n = Indent n + +-- | \"Above\": puts one document on top of another. +(>-<) :: Doc -> Doc -> Doc +(>-<) = Above + +-- | Stacks multiple documents: @above = foldr (>-<) empty@. +above :: [Doc] -> Doc +above = foldr (>-<) empty + +-- | \"Besides\": puts two documents next to eachother by \"dovetailing\" them. +(>|<) :: Doc -> Doc -> Doc +(>|<) = Besides + +-- | Queues multiple documents: @besides = foldr (>|<) empty@. +besides :: [Doc] -> Doc +besides = foldr (>|<) empty + +------------------------------------------------------------------------------- +-- Parallelisation +------------------------------------------------------------------------------- + +infixr 1 >//<, >^< + +-- | \"Split\": introduces two alternative (\"parallel\") formattings. +(>//<) :: Doc -> Doc -> Doc +(>//<) = Split + +-- | Introduces multiple alternative formattings: +-- @split = foldr (>\/\/<) empty@. +split :: [Doc] -> Doc +split = foldr (>//<) empty + +-- | Selects the most space-efficient of all alternative formattings for a +-- document. +join :: Doc -> Doc +join = Join + +-- | Immediate choice: @l >^\< r = join (l >\/\/< r)@. +(>^<) :: Doc -> Doc -> Doc +l >^< r = join (l >//< r) + +-- | Immediate choice: @choose = foldr (>^<) empty@. +choose :: [Doc] -> Doc +choose = foldr (>^<) empty + +------------------------------------------------------------------------------- +-- Punctuation +------------------------------------------------------------------------------- + +infixr 3 >#< + +-- | A space character: @space = text \" \"@. +space :: Doc +space = text " " + +-- | A full stop: @period = text \".\"@. +period :: Doc +period = text "." + +-- | A comma: @comma = text \",\"@. +comma :: Doc +comma = text "," + +-- | A semicolon: @semicolon = text \";\"@. +semicolon :: Doc +semicolon = text ";" + +-- | A colon: @colon = text \":\"@. +colon :: Doc +colon = text ":" + +-- | Inserts a delimiter between all adjacent nonempty documents in a list. +sepBy :: [Doc] -> Doc -> Doc +sepBy [] _ = empty +sepBy [doc] _ = doc +sepBy (l : docs@(r : docs')) sep + | isEmpty l = sepBy docs sep + | isEmpty r = sepBy (l : docs') sep + | otherwise = sepBy ((l >|< sep >|< r) : docs') sep + +-- | Inserts a space between two documents. +-- If one of the documents is empty, the other one is returned: +-- @l >#< r = [l, r] \`sepBy\` space@. +(>#<) :: Doc -> Doc -> Doc +l >#< r = [l, r] `sepBy` space + +-- | Parentheses: +-- +-- > lparen = text "(" +-- > rparen = text ")" + +lparen, rparen :: Doc +lparen = text "(" +rparen = text ")" + +-- | Square brackets: +-- +-- > lbracket = text "[" +-- > rbracket = text "]" + +lbracket, rbracket :: Doc +lbracket = text "[" +rbracket = text "]" + +-- | Curly braces: +-- +-- > lbrace = text "{" +-- > rbrace = text "}" + +lbrace, rbrace :: Doc +lbrace = text "{" +rbrace = text "}" + +-- | Angle brackets: +-- +-- > langle = text "<" +-- > rangle = text ">" + +langle, rangle :: Doc +langle = text "<" +rangle = text ">" + +-- | Encloses a document in brackets: +-- @enclose l r d = l >|\< d >|\< r@. +enclose :: Doc -> Doc -> Doc -> Doc +enclose l r d = l >|< d >|< r + +-- | Encloses a document in parentheses: @parens = enclose lparen rparen@. +parens :: Doc -> Doc +parens = enclose lparen rparen + +-- | Encloses a document in square brackets: +-- @brackets = enclose lbracket rbracket@. +brackets :: Doc -> Doc +brackets = enclose lbracket rbracket + +-- | Encloses a document in curly braces: @braces = enclose lbrace rbrace@. +braces :: Doc -> Doc +braces = enclose lbrace rbrace + +-- | Encloses a document in angle brackets: @angles = enclose langle rangle@. +angles :: Doc -> Doc +angles = enclose langle rangle + +------------------------------------------------------------------------------- +-- Colours +------------------------------------------------------------------------------- + +-- | Sets the foreground colour of a document to black. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +black :: Doc -> Doc +black = Colour Black + +-- | Sets the foreground colour of a document to red. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +red :: Doc -> Doc +red = Colour Red + +-- | Sets the foreground colour of a document to green. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +green :: Doc -> Doc +green = Colour Green + +-- | Sets the foreground colour of a document to blue. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +blue :: Doc -> Doc +blue = Colour Blue + +-- | Sets the foreground colour of a document to yellow. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +yellow :: Doc -> Doc +yellow = Colour Yellow + +-- | Sets the foreground colour of a document to magenta. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +magenta :: Doc -> Doc +magenta = Colour Magenta + +-- | Sets the foreground colour of a document to cyan. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +cyan :: Doc -> Doc +cyan = Colour Cyan + +-- | Sets the foreground colour of a document to white. +-- +-- (Note: colours are only taken into account when a document is rendered by +-- means of 'renderIO' or 'renderIO_'. +-- They are ignored if 'render' or 'render_' are used.) + +white :: Doc -> Doc +white = Colour White + +------------------------------------------------------------------------------- +-- Rendering +------------------------------------------------------------------------------- + +-- | Tries to render a document with a specified amount of horizontal space and +-- to invoke the supplied function on the resulting printer. +renderWith :: Printer a => (a -> b) -> Int -> Doc -> Maybe b +renderWith f wmax doc = fmap f (R.render wmax doc) + +-- | Tries to render a document with a specified amount of horizontal space and +-- to invoke the supplied function on the resulting printer. +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +renderWith_ :: Printer a => (a -> b) -> Int -> Doc -> b +renderWith_ f wmax doc = head $ catMaybes $ fmap (\w -> renderWith f w doc) ws + where + ws = iterate (\w -> w + 1 `max` (w `div` 10)) wmax + +-- | Tries to render a document with a specified amount of horizontal space and +-- to invoke the supplied function on the resulting printer. +-- The result of the function is tupled with the number of new lines claimed by +-- the rendering. +renderHeightWith :: Printer a => (a -> b) -> Int -> Doc -> Maybe (b, Int) +renderHeightWith f wmax doc = fmap (f &&& height) (R.render wmax doc) + +-- | Tries to render a document with a specified amount of horizontal space and +-- to invoke the supplied function on the resulting printer. +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +-- The resulting rendering is tupled with the number of new lines claimed by +-- the rendering. +renderHeightWith_ :: Printer a => (a -> b) -> Int -> Doc -> (b, Int) +renderHeightWith_ f wmax doc + = head $ catMaybes $ fmap (\w -> renderHeightWith f w doc) ws + where + ws = iterate (\w -> w + 1 `max` (w `div` 10)) wmax + +-- | Tries to render a document within a specified amount of horizontal space. +render :: Int -> Doc -> Maybe String +render = renderWith printToString + +-- | Tries to render a document within a specified amount of horizontal space. +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +render_ :: Int -> Doc -> String +render_ = renderWith_ printToString + +-- | Tries to render a document within a specified amount of horizontal space. +-- A resulting rendering is tupled with the number of new lines claimed by the +-- rendering. +renderHeight :: Int -> Doc -> Maybe (String, Int) +renderHeight = renderHeightWith printToString + +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +-- The resulting rendering is tupled with the number of new lines claimed by +-- the rendering. +renderHeight_ :: Int -> Doc -> (String, Int) +renderHeight_ = renderHeightWith_ printToString + +-- | Tries to render a document within a specified amount of horizontal space +-- and to print it to the standard output channel. +renderIO :: Int -> Doc -> Maybe (IO ()) +renderIO = renderWith printToIO + +-- | Tries to render a document within a specified amount of horizontal space +-- and to print it to the standard output channel. +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +renderIO_ :: Int -> Doc -> IO () +renderIO_ = renderWith_ printToIO + +-- | Tries to render a document within a specified amount of horizontal space +-- and to print it to the standard output channel. +-- A resulting rendering is tupled with the number of new lines claimed by the +-- rendering. +renderIOHeight :: Int -> Doc -> Maybe (IO (), Int) +renderIOHeight = renderHeightWith printToIO + +-- | Tries to render a document within a specified amount of horizontal space +-- and to print it to the standard output channel. +-- If the document cannot be rendered within the given amount of space, the +-- amount of space is, until the document fits, repeatedly enlarged by 10 +-- percent. +-- The resulting rendering is tupled with the number of new lines claimed by +-- the rendering. +renderIOHeight_ :: Int -> Doc -> (IO (), Int) +renderIOHeight_ = renderHeightWith_ printToIO + +------------------------------------------------------------------------------- +-- The class Printable +------------------------------------------------------------------------------- + +-- | The class @Printable@. +-- Instances of @Printable@ provide a pretty printer for their values. +-- +-- A minimal complete definition must supply the method @pp@. + +class Printable a where + -- | Retrieves a pretty-printable document for a value. + pp :: a -> Doc + +instance Printable Char where pp = showable +instance Printable Int where pp = showable +instance Printable Integer where pp = showable +instance Printable Float where pp = showable +instance Printable Double where pp = showable + +------------------------------------------------------------------------------- +-- Printing showables +------------------------------------------------------------------------------- + +-- | Prints a 'Show'able value: @showable = text . show@. +showable :: Show a => a -> Doc +showable = text . show diff --git a/src/CCO/Printing/Colour.hs b/src/CCO/Printing/Colour.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Printing/Colour.hs @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Printing.Colour +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- The 'Colour' type. +-- +------------------------------------------------------------------------------- + +module CCO.Printing.Colour ( + -- The Colour type + Colour (..) + ) where + +------------------------------------------------------------------------------- +-- The Colour type +------------------------------------------------------------------------------- + +-- | The @Colour@ type. +data Colour = Default + | Black + | Red + | Green + | Blue + | Yellow + | Magenta + | Cyan + | White diff --git a/src/CCO/Printing/Doc.hs b/src/CCO/Printing/Doc.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Printing/Doc.hs @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Printing.Rendering +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Type of pretty-printable documents. +-- +------------------------------------------------------------------------------- + +module CCO.Printing.Doc ( + -- * Type of pretty-printable documents + Doc (..) + , isEmpty -- :: Doc -> Bool + ) where + +import CCO.Printing.Colour (Colour) + +------------------------------------------------------------------------------- +-- Type of pretty-printable documents +------------------------------------------------------------------------------- + +-- | The type of documents. +data Doc = Empty -- ^ The empty document. + | Text String -- ^ A text. + | Wrapped String -- ^ A wrapped text. + | Indent Int Doc -- ^ A document indented by a give amount of + -- horizontal space. + | Above Doc Doc -- ^ One document on top of another document. + | Besides Doc Doc -- ^ Two \"dovetailed\" documents. + | Split Doc Doc -- ^ Introduces parallel renderings. + | Join Doc -- ^ Joins all parallel renderings into one + -- rendering. + | Colour Colour Doc -- ^ A document printed in a specified colour. + +-- | Indicates whether a document is empty. +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False diff --git a/src/CCO/Printing/Printer.hs b/src/CCO/Printing/Printer.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Printing/Printer.hs @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Printing.Printer +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- The 'Printer' class and two instances. +-- +-- Instances of 'Printer' model low-level devices for outputting the basic +-- elements (text, whitespace, and line breaks) of pretty-printable documents. +-- +------------------------------------------------------------------------------- + +module CCO.Printing.Printer ( + -- * The Printer class + Printer (..) -- superclasses: Monoid + + -- * Printing to strings + , StringPrinter -- abstract, instances: Monoid, Printer + , printToString -- :: StringPrinter -> String + + -- * Printing to the standard output channel + , IOPrinter -- abstract, instances: Monoid, Printer + , printToIO -- :: IOPrinter -> IO () + ) where + +import CCO.Printing.Colour ( Colour (..) ) +import Data.Monoid ( Monoid (..) ) +import System.Console.ANSI ( ConsoleLayer (Foreground) + , ColorIntensity (Dull) + , SGR (Reset, SetColor) + , setSGR + ) +import qualified System.Console.ANSI as A ( Color (..) ) + +------------------------------------------------------------------------------- +-- The Printer class +------------------------------------------------------------------------------- + +-- | The @Printer@ class. +-- +-- A minimal complete definition must supply the methods @ptext@, @ws@, +-- @newLine@, @width@, and @height@. +-- +-- Instances of @Printer@ are also instances of 'Monoid' and should be in such +-- a way that 'mempty' prints the empty document and 'mappend' produces a +-- printer that runs its constituent printers consecutively. +-- +-- Instances of @Printer@ should satisfy the following laws: +-- +-- > width mempty == 0 +-- > width (ptext txt) == length txt +-- > width (ws n) == n +-- > width newLine == 0 +-- > width (beginColour c) == 0 +-- > width endColour == 0 +-- > width (pl `mappend` pr) == width pl + width pr +-- > height mempty == 0 +-- > height (ptext txt) == 0 +-- > height (ws n) == 0 +-- > height newLine == 1 +-- > height (beginColour c) == 0 +-- > height endColour == 0 +-- > height (pl `mappend` pr) == height pl + height pr + +class Monoid a => Printer a where + -- | Prints a given single-line text. + ptext :: String -> a + -- | Prints the specifed amount of whitespace. + ws :: Int -> a + -- | Moves to the next line. + newLine :: a + -- | Select a foreground colour. + beginColour :: Colour -> a + -- | Select the previous foreground colour. + endColour :: a + -- | Produces the amount of horizontal space to be claimed. + width :: a -> Int + -- | Produces the number of new lines to be claimed. + height :: a -> Int + + beginColour = mempty + endColour = mempty + +------------------------------------------------------------------------------- +-- Printing to strings +------------------------------------------------------------------------------- + +-- | The type of printers that produce 'String's. +data StringPrinter = SP !Int !Int (String -> String) + +instance Monoid StringPrinter where + mempty = SP 0 0 id + mappend (SP wl hl accl) (SP wr hr accr) = + SP (wl + wr) (hl + hr) (accl . accr) + +instance Printer StringPrinter where + ptext txt = SP (length txt) 0 (txt ++) + ws n = SP n 0 (take n spaces ++) + newLine = SP 0 1 ("\n" ++) + width (SP w _ _) = w + height (SP _ h _) = h + +-- | Runs a 'StringPrinter'. +printToString :: StringPrinter -> String +printToString (SP _ _ acc) = acc "" + +------------------------------------------------------------------------------- +-- Printing to the standard output channel +------------------------------------------------------------------------------- + +-- | The type of printers that print to the standard output channel. +data IOPrinter = IOP !Int !Int ([Colour] -> (IO (), [Colour])) + +instance Monoid IOPrinter where + mempty = IOP 0 0 (\cs -> (return (), cs)) + mappend (IOP wl hl f) (IOP wr hr g) = IOP (wl + wr) (hl + hr) $ \cs -> + let (iol, cs') = f cs + (ior, cs'') = g cs' + in (iol >> ior, cs'') + +instance Printer IOPrinter where + ptext txt = IOP (length txt) 0 (\cs -> (putStr txt, cs)) + ws n = IOP n 0 (\cs -> (putStr (take n spaces), cs)) + newLine = IOP 0 1 (\cs -> (putStrLn "", cs)) + beginColour c = IOP 0 0 (\cs -> (setColour c, c : cs)) + endColour = IOP 0 0 (\(_ : cs@(c : _)) -> (setColour c, cs)) + width (IOP w _ _) = w + height (IOP _ h _) = h + +-- | Sets the foreground colour. +setColour :: Colour -> IO () +setColour Default = setSGR [Reset ] +setColour Black = setSGR [SetColor Foreground Dull A.Black ] +setColour Red = setSGR [SetColor Foreground Dull A.Red ] +setColour Green = setSGR [SetColor Foreground Dull A.Green ] +setColour Blue = setSGR [SetColor Foreground Dull A.Blue ] +setColour Yellow = setSGR [SetColor Foreground Dull A.Yellow ] +setColour Magenta = setSGR [SetColor Foreground Dull A.Magenta] +setColour Cyan = setSGR [SetColor Foreground Dull A.Cyan ] +setColour White = setSGR [SetColor Foreground Dull A.White ] + +-- | Runs an 'IOPrinter'. +printToIO :: IOPrinter -> IO () +printToIO (IOP _ _ f) = fst (f [Default]) + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | An infinite supply of spaces. +spaces :: [Char] +spaces = ' ' : spaces diff --git a/src/CCO/Printing/Rendering.hs b/src/CCO/Printing/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Printing/Rendering.hs @@ -0,0 +1,330 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Printing.Rendering +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Facilities for rendering pretty-printable documents. +-- +------------------------------------------------------------------------------- + +module CCO.Printing.Rendering ( + render -- :: Printer a => Int -> Doc -> Maybe a + ) where + +import CCO.Printing.Colour (Colour) +import CCO.Printing.Doc (Doc (..)) +import CCO.Printing.Printer (Printer (..)) +import Data.Maybe (listToMaybe) +import Data.Monoid (Monoid (..)) +import Data.List (intersperse) + +-- This module is at the heart of the pretty-printing library. + +-- Rendering involves a hierarchy of data structures, that share a common +-- interface ('PP'). +-- At the top of the hierarchy, we have 'Formatters' that, given a amount of +-- available horizontal space, spawn a list of all possible 'Format's, from +-- which concrete printers can be obtained. + +-- Across the hierarchy, empty documents are expected to not appear as operands +-- to \"above\" or \"besides\" operations. +-- (The hence necessary normalisation is performed within the function +-- 'fromDoc'.) + +------------------------------------------------------------------------------- +-- The PP class +------------------------------------------------------------------------------- + +-- | The common interface of the data structures in the rendering hierarchy. +-- +-- A minimal complete definition must supply all six methods, i.e., @ppEmpty@, +-- @ppText@, @ppIndent@, @ppAbove@, @ppBesides@, and @ppColour@. + +class PP a where + -- | Involved in rendering the empty document. + ppEmpty :: a + -- | Involved in rendering text. + ppText :: String -> a + -- ^ Involved in rendering an indented document. + ppIndent :: Int -> a -> a + -- ^ Involved in rendering two stacked up documents. + ppAbove :: a -> a -> a + -- ^ Involved in rendering two \"dovetailed\" documents. + ppBesides :: a -> a -> a + -- ^ Involved in rendering coloured output. + ppColour :: Colour -> a -> a + +------------------------------------------------------------------------------- +-- Concrete renderings +------------------------------------------------------------------------------- + +-- | The most low-level data structure in the rendering hierarchy. +-- +-- A @Rendering@ holds a list of printers: one for each printed line within the +-- rendered document. + +newtype Rendering a = R [a] + +instance Printer a => PP (Rendering a) where + ppEmpty = R [] + ppText txt = R [ptext txt] + ppIndent n (R ps) = R (map (ws n `mappend`) ps) + ppAbove (R psl) (R psr) = R (psl ++ psr) + + -- \"dovetailing\" involves concatenating + -- * all but the last of the lines in the left-hand side rendering; + -- * the line obtained by glueing together the last and the first line of + -- the left- and right-hand side renderings, respectively; and + -- * the lines obtained by prefixing all but the first of the lines in the + -- right-hand side rendering with an amount of whitespace that matches the + -- width of the last line in the left-hand side rendering + ppBesides (R []) rr = rr + ppBesides rl (R []) = rl + ppBesides (R psl) (R (pr : psr')) = let (psl', pl) = unSnoc psl + prefix = ws (width pl) + in R $ psl' ++ [pl `mappend` pr] ++ + map (prefix `mappend`) psr' + + ppColour _ r@(R []) = r + ppColour c (R [p]) = R [beginColour c `mappend` p `mappend` endColour] + ppColour c (R (p : ps)) = let (ps', p') = unSnoc ps + in R $ beginColour c `mappend` p : + ps' ++ [p' `mappend` endColour] + +------------------------------------------------------------------------------- +-- Dimensions +------------------------------------------------------------------------------- + +-- | Provides an abstraction of a 'Rendering': the total height, total width, +-- and the width of the last line of a rendering. +data Dim = D !Int !Int !Int + +instance PP Dim where + ppEmpty = D 0 0 0 + ppText txt = D 1 w w where w = length txt + ppIndent n (D h w l) = D h (w + n) (l + n) + ppAbove (D hl wl _) (D hr wr lr) = D (hl + hr) (wl `max` wr) lr + ppBesides (D hl _ ll) (D hr wr lr) = D (hl + hr - 1) (ll + wr) (ll + lr) + ppColour _ d = d + +------------------------------------------------------------------------------- +-- Formats +------------------------------------------------------------------------------- + +-- | A concrete 'Rendering' together with its 'Dim'-abstraction. +data Format a = Rendering a :^ Dim + +instance Printer a => PP (Format a) where + ppEmpty = ppEmpty :^ ppEmpty + ppText txt = ppText txt :^ ppText txt + ppIndent n (r :^ d) = ppIndent n r :^ ppIndent n d + ppAbove (rl :^ dl) (rr :^ dr) = ppAbove rl rr :^ ppAbove dl dr + ppBesides (rl :^ dl) (rr :^ dr) = ppBesides rl rr :^ ppBesides dl dr + ppColour c (r :^ d) = ppColour c r :^ ppColour c d + +------------------------------------------------------------------------------- +-- Formatters +------------------------------------------------------------------------------- + +-- | Represents the minimal amount of horizontal space needed to render a +-- document, expressed in terms of the total width and the width of the last +-- line in the most efficient rendering. +type Frame = (Int, Int) + +-- | The top-level data structure in the rendering hierarchy: it provides the +-- minimal amount of horizontal space needed to render the document (expressed +-- in terms of a 'Frame') together with a function that spawns all possible +-- formats for a document that fit within a specifed amount of horizontal +-- space (expressed in terms of the total width of a rendering). +-- +-- @Formatter@s maintain the invariant that the lists of possible formats are +-- sorted on ascending heights and descending widths /simultaneously/. + +data Formatter a = Frame :< (Int -> [Format a]) + +instance Printer a => PP (Formatter a) where + ppEmpty = (0, 0) :< \_ -> [ppEmpty] + ppText txt = let w = length txt + in (w, w) :< \wmax -> if w <= wmax then [ppText txt] else [] + + ppIndent n ((wmin, lmin) :< spwn) + = (wmin + n, lmin + n) :< \wmax -> + [ppIndent n fmt | fmt <- spwn (wmax - n)] + + -- * if we stack to documents, we have to be careful not to generate too many + -- formats; + -- * more specifically, we do not have to take the cross product of the lists + -- of formats for the upper document and the lower document + -- * rather, if we move through the lists in order of descending widths, it + -- is sufficient to combine each format with at most one format of lesser + -- or equal width: combining it with other formats of lesser width cannot + -- yield narrower formats, for the width of the format itself will + -- determine the combined width with those other formats; + -- * therefore, we can process the two lists of formats in a left-to-right + -- fashion, as implemented by the auxiliary function 'stack' + + ppAbove ((wminl, _) :< spwnl) ((wminr, lminr) :< spwnr) + = (wminl `max` wminr, lminr) :< \wmax -> + if wminl <= wmax && wminr <= wmax + then stack (spwnl wmax) (spwnr wmax) + else [] + + -- * a straightforward approach to \"dovetailing\" would be to first spawn + -- all formats that fit the available horizontal space for the left-hand + -- document and then, /for each of these formats/, determine the amount of + -- space left and spawn all fiting formats for the right-hand document; + -- * however, this can be rather costly if there are many fitting formats for + -- the left-hand document; + -- * therefore, we adopt an alternative technique: we spawn all left-hand + -- formats and use the lower bound on the widths of their last lines + -- (provided by the 'Frame' component of the left-hand formatter) as a + -- conservative estimate on the amount of horizontal space available for + -- the right-hand formats; + -- * this way, we may end up with combined formats that are too wide + -- * so, after combining the formats, the ones that occupy too much space are + -- cut off + ppBesides ((_, lminl) :< spwnl) ((wminr, lminr) :< spwnr) + = (lminl + wminr, lminl + lminr) :< \wmax -> + let fmtsl = spwnl wmax + fmtsr = spwnr (wmax - lminl) + in if lminl + wminr <= wmax + then (cut wmax . foldr merge []) + [[ppBesides fmtl fmtr | fmtr <- fmtsr] | fmtl <- fmtsl] + else [] + + ppColour c (frm :< spwn) = (frm :< \wmax -> map (ppColour c) (spwn wmax)) + +-- | Drops all 'Format's that do not fit within a specified amount of +-- horizontal space (expressed as the total width of a rendering). +cut :: Int -> [Format a] -> [Format a] +cut wmax = dropWhile tooWide -- we can use 'dropWhile', for we may assume + -- that the formats are sorted on descending + -- widths + where + tooWide (_ :^ D _ w _) = w > wmax + +-- | A (proper) partial order on formats, according to which the lists +-- produced by 'Formatter's are sorted. +(<=.) :: Format a -> Format a -> Bool +(_ :^ D hl wl _) <=. (_ :^ D hr wr _) = hl <= hr && wl >= wr + +-- | Merges two lists of 'Format's preserving the '(<=.)'-ordering of their +-- elements. +-- +-- Because '(<=.)' is a proper partial order, elements from the right-hand +-- list may be dropped if they cannot be merged into the left-hand side list. + +merge :: [Format a] -> [Format a] -> [Format a] +merge [] fmtsr = fmtsr +merge fmtsl [] = fmtsl +merge fmtsl@(fmtl : fmtsl') fmtsr@(fmtr : fmtsr') + | fmtl <=. fmtr = fmtl : merge fmtsl' fmtsr + | fmtr <=. fmtl = fmtr : merge fmtsl fmtsr' + | otherwise = fmtl : merge fmtsl' fmtsr' + +-- | Takes two sorted lists of formats and combines them to form a list that +-- containts the most efficient formats obtained by stacking formats from the +-- first list on top of formats from the second list. +-- +-- (Auxiliary to the implementation of 'ppAbove' for 'Formatter'.) + +stack :: Printer a => [Format a] -> [Format a] -> [Format a] +stack [] fmtsr = [] +stack fmtsl [] = [] +stack fmtsl@(fmtl : fmtsl') fmtsr@(fmtr : fmtsr') = case (fmtl, fmtr) of + (_ :^ D _ wl _, _ :^ D _ wr _) + | wl <= wr -> ppAbove fmtl fmtr : stack fmtsl fmtsr' + | otherwise -> ppAbove fmtl fmtr : stack fmtsl' fmtsr + +-- | Takes a single-line text and produces a @Formatter@ for +-- its \'paragraph fill'. +ppWrapped :: Printer a => String -> Formatter a +ppWrapped txt = frm :< \wmax -> if null wrds then [ppText ""] else + let ws = [wmax, wmax - minw .. minw] + in [ppFill w wrds | w <- ws] + where + wrds = [(txt', length txt') | txt' <- words txt] + lengths = map snd wrds + frm@(minw, _) | null wrds = (0, 0) + | otherwise = (maximum lengths, last lengths) + +-- | Takes a list of words and their lengths and produces the 'Format' for its +-- \"paragraph\" fill with respect to a given paragraph width. +-- Words on the same line are separated by a single whitespace character. +ppFill :: Printer a => Int -> [(String, Int)] -> Format a +ppFill _ [] = ppText "" +ppFill wmax wrds = foldr1 ppAbove . map (ppText . unwords) . fill (-1) id $ + wrds + where + fill _ acc [] = [acc []] + fill n acc wrds@((txt, len) : wrds') + | n + len <= wmax - 1 = fill (n + len + 1) (acc . (txt :)) wrds' + | otherwise = acc [] : fill (- 1) id wrds + +-- | Parallelisation: combines two alternative formatters into a single +-- formatter. +ppSplit :: Formatter a -> Formatter a -> Formatter a +ppSplit ((wminl, lminl) :< spwnl) ((wminr, lminr) :< spwnr) + = (wminl `min` wminr, lminl `min` lminr) :< \wmax -> case () of + _ | wminl <= wmax && wminr < wmax -> merge (spwnl wmax) (spwnr wmax) + | wminl <= wmax -> spwnl wmax + | wminr <= wmax -> spwnr wmax + | otherwise -> [] + +-- | Joins all parallel formats into a single format. +ppJoin :: Formatter a -> Formatter a +ppJoin (frm :< spwn) = frm :< \wmax -> case spwn wmax of + [] -> [] + fmt : _ -> [fmt] + +------------------------------------------------------------------------------- +-- Interface +------------------------------------------------------------------------------- + +-- | Retrieves a concrete printer for a 'Format'. +toPrinter :: Printer a => Format a -> a +toPrinter (R ps :^ _) = mconcat (intersperse newLine ps) + +-- | Produces a formatter for a 'Doc'. + +fromDoc :: Printer a => Doc -> Formatter a +fromDoc Empty = ppEmpty +fromDoc (Text txt) = ppText txt +fromDoc (Wrapped txt) = ppWrapped txt +fromDoc (Indent n d) = ppIndent n (fromDoc d) +fromDoc (Above Empty r) = fromDoc r +fromDoc (Above l Empty) = fromDoc l +fromDoc (Above l r) = ppAbove (fromDoc l) (fromDoc r) +fromDoc (Besides Empty r) = fromDoc r +fromDoc (Besides l Empty) = fromDoc l +fromDoc (Besides l r) = ppBesides (fromDoc l) (fromDoc r) +fromDoc (Split l r) = ppSplit (fromDoc l) (fromDoc r) +fromDoc (Join d) = ppJoin (fromDoc d) +fromDoc (Colour _ Empty) = ppEmpty +fromDoc (Colour c d) = ppColour c (fromDoc d) + +-- | Produces a printer for the most efficient rendering of a document within +-- a specified amount of horizontal space. +-- Returns 'Nothing' if the document cannot be rendered within the given amount +-- of space. +render :: Printer a => Int -> Doc -> Maybe a +render wmax doc = listToMaybe $ fmap toPrinter $ spwn wmax + where + _ :< spwn = fromDoc doc + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Breaks up a list into its 'init' and 'last' parts. +-- Undefined for empty lists. +unSnoc :: [a] -> ([a], a) +unSnoc = unsnc id + where + unsnc acc [x] = (acc [], x) + unsnc acc (x : xs) = unsnc (acc . (x :)) xs diff --git a/src/CCO/SourcePos.hs b/src/CCO/SourcePos.hs new file mode 100644 --- /dev/null +++ b/src/CCO/SourcePos.hs @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.SourcePos +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Representation of source positions. +-- +------------------------------------------------------------------------------- + +module CCO.SourcePos ( + -- * Source positions + Source (File, Stdin) -- instances: Eq, Show, Read, Tree + , Pos (Pos, EOF) -- instances: Eq, Show, Read, Tree + , SourcePos (SourcePos) -- instances: Eq, Show, Read, Tree +) where + +import CCO.Tree.ATerm (ATerm (App)) +import CCO.Tree.Base (Tree (fromTree, toTree)) +import CCO.Tree.Instances () +import CCO.Tree.Parser (parseTree, app, arg) +import Control.Applicative (Applicative (pure, (<*>)), (<$>)) + +------------------------------------------------------------------------------- +-- Source positions +------------------------------------------------------------------------------- + +-- | A description of an input stream. +data Source = File FilePath -- ^ A file. + | Stdin -- ^ The standard input channel. + deriving (Eq, Show, Read) + +instance Tree Source where + fromTree (File filePath) = App "File" [fromTree filePath] + fromTree Stdin = App "Stdin" [] + + toTree = parseTree [app "File" (File <$> arg), app "Stdin" (pure Stdin)] + +-- | A position. +data Pos = Pos !Int !Int -- ^ An actual position (line number, column + -- number). + | EOF -- ^ End of input. + deriving (Eq, Show, Read) + +instance Tree Pos where + fromTree (Pos line column) = App "Pos" [fromTree line, fromTree column] + fromTree EOF = App "EOF" [] + + toTree = parseTree [app "Pos" (Pos <$> arg <*> arg), app "EOF" (pure EOF)] + +-- | A position in an input stream. +data SourcePos = SourcePos Source Pos -- ^ Combines a 'Source' and a 'Pos'. + deriving (Eq, Show, Read) + +instance Tree SourcePos where + fromTree (SourcePos src pos) = App "SourcePos" [fromTree src, fromTree pos] + toTree = parseTree [app "SourcePos" (SourcePos <$> arg <*> arg)] diff --git a/src/CCO/Tree.hs b/src/CCO/Tree.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree.hs @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A straightforward implementation of the ATerm format for exchanging +-- tree-structured data; see +-- +-- * Mark van den Brand, Hayco de Jong, Paul Klint, and Pieter A. Olivier. +-- Efficient annotated terms. +-- /Software - Practice and Experience (SPE)/, 30(3):259-291, 2000. +-- +------------------------------------------------------------------------------- + +module CCO.Tree ( + -- * The @ATerm@ type + ATerm (..) -- instances: Eq, Read, Show, Printable + , Con -- = String + + -- * The @Tree@ class + , Tree (..) + + -- * Parser + , parser -- :: Component String ATerm +) where + +import CCO.Tree.ATerm (Con, ATerm (..)) +import CCO.Tree.ATerm.Parser (parser) +import CCO.Tree.Base (Tree (fromTree, toTree)) +import CCO.Tree.Instances () diff --git a/src/CCO/Tree/ATerm.hs b/src/CCO/Tree/ATerm.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/ATerm.hs @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.ATerm +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A straightforward implementation of the ATerm format for exchanging +-- tree-structured data; see +-- +-- * Mark van den Brand, Hayco de Jong, Paul Klint, and Pieter A. Olivier. +-- Efficient annotated terms. +-- /Software - Practice and Experience (SPE)/, 30(3):259-291, 2000. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.ATerm ( + -- * The @ATerm@ type + ATerm (..) -- instances: Eq, Read, Show, Printable + , Con -- = String + ) where + +import CCO.Printing +import Data.List + +------------------------------------------------------------------------------- +-- The ATerm type +------------------------------------------------------------------------------- + +-- | Node constructors. +type Con = String + +-- | Terms. +data ATerm = Integer Integer -- ^Integer literal. + | Float Double -- ^Floating-point literal. + | String String -- ^Textual literal. + | App Con [ATerm] -- ^Constructor application. + | Tuple [ATerm] -- ^Tuple of terms. + | List [ATerm] -- ^List of terms. + | Ann ATerm [ATerm] -- ^Annotated term. + deriving (Eq, Read, Show) + +instance Printable ATerm where pp = ppATerm + +------------------------------------------------------------------------------- +-- Pretty printing +------------------------------------------------------------------------------- + +-- We distinguish between two fundamental modes for printing compound 'ATerm's +-- (i.e., 'App's, 'Tuple's, 'List's, and 'Ann's): single-line mode and +-- multi-line mode. +-- Subterms of a term printed in single-line mode are themselves required to +-- be printed in single-line mode; subterms of a term printed in multi-line +-- mode may be printed in either mode. + +-- | Representation of the printing modes: a function that takes the a +-- \"preamble\", a left bracket symbol, a right bracket symbol, and a list of +-- subterms as arguments and produces a 'Doc' for the compound term that is to +-- be printed. +type Mode = Doc -> -- \"Preamble\". + Doc -> -- Left bracket. + Doc -> -- Right bracket. + [ATerm] -> -- List of subterms. + Doc -- 'Doc' for the compound term. + +-- | Single-line mode. +singleLineMode :: Mode +singleLineMode = \pre l r ts -> + let docs = [ppATermIn singleLineMode t | t <- ts] `sepBy` text ", " + in pre >|< l >|< docs >|< r + +-- | Multi-line mode. +multiLineMode :: Mode +multiLineMode = \pre l r ts -> + singleLineMode pre l r ts >//< case ts of + [] -> pre >|< l >-< r + t : ts' -> + let p = if isEmpty pre then l >|< text " " else pre >|< l >-< text " " + in p >|< ppATermIn multiLineMode t >-< + above [text ", " >|< ppATermIn multiLineMode t' | t' <- ts'] >-< + r + +-- | Pretty prints an 'ATerm' in multi-line mode. +ppATerm :: ATerm -> Doc +ppATerm = ppATermIn multiLineMode + +ppATermIn :: Mode -> ATerm -> Doc +ppATermIn _ (Integer n) = pp n +ppATermIn _ (Float r) = pp r +ppATermIn _ (String txt) = text (show txt) +ppATermIn _ (App c []) = blue (text c) +ppATermIn mode (App c ts) = mode (blue (text c)) lparen rparen ts +ppATermIn mode (Tuple ts) = mode empty lparen rparen ts +ppATermIn mode (List ts) = mode empty lbracket rbracket ts +ppATermIn mode (Ann t ts) = mode (ppATermIn mode t) lbrace rbrace ts diff --git a/src/CCO/Tree/ATerm/Lexer.hs b/src/CCO/Tree/ATerm/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/ATerm/Lexer.hs @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.ATerm.Lexer +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A 'Lexer' for 'ATerm's. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.ATerm.Lexer ( + -- * Tokens + Token -- abstract, instance: Symbol + + -- * Lexer + , lexer -- :: Lexer Token + + -- * Token parsers + , integer -- :: Parser Token Integer + , float -- :: Parser Token Double + , string -- :: Parser Token String + , con -- :: Parser Token Con + , spec -- :: Char -> Parser Token Char +) where + +import CCO.Lexing hiding (satisfy, string) +import CCO.Parsing (Symbol (describe), Parser, satisfy, ()) +import CCO.Tree.ATerm (Con) +import Control.Applicative +import Data.Char (chr) +import Prelude hiding (fromInteger) + +------------------------------------------------------------------------------- +-- Tokens +------------------------------------------------------------------------------- + +-- | Type of ATerm tokens. +data Token + = Integer { fromInteger :: Integer } -- ^ Integer literal. + | Float { fromFloat :: Double } -- ^ Floating-point literal. + | String { fromString :: String } -- ^ String literal. + | Con { fromCon :: Con } -- ^ Constructor symbol. + | Spec { fromSpec :: Char } -- ^ Special character. + +instance Symbol Token where + describe (Integer _) lexeme = "integer literal " ++ lexeme + describe (Float _) lexeme = "floating-point literal " ++ lexeme + describe (String _) lexeme = "string literal " ++ lexeme + describe (Con _) lexeme = "constructor symbol " ++ lexeme + describe (Spec _) lexeme = show lexeme + +-- | Retrieves whether a 'Token' is an 'Integer'. +isInteger :: Token -> Bool +isInteger (Integer _) = True +isInteger _ = False + +-- | Retrieves whether a 'Token' is a 'Float'. +isFloat :: Token -> Bool +isFloat (Float _) = True +isFloat _ = False + +-- | Retrieves whether a 'Token' is a 'String'. +isString :: Token -> Bool +isString (String _) = True +isString _ = False + +-- | Retrieves whether a 'Token' is a 'Con'. +isCon :: Token -> Bool +isCon (Con _) = True +isCon _ = False + +-- | Retrieves whether a 'Token' is a 'Spec'. +isSpec :: Token -> Bool +isSpec (Spec _) = True +isSpec _ = False + +------------------------------------------------------------------------------- +-- Lexer +------------------------------------------------------------------------------- + +-- | A 'Lexer' that recognises (and ignores) whitespace. +layout_ :: Lexer Token +layout_ = ignore (some (char ' ' <|> char '\n' <|> char '\t')) + +-- | A 'Lexer' that recognises 'Integer' tokens. +integer_ :: Lexer Token +integer_ = Integer <$> integerPart + +-- | A 'Lexer' that recognises 'Float' tokens. +float_ :: Lexer Token +float_ = (\n f -> Float (f n)) <$> integerPart <*> floatPart + +-- | A 'Lexer' that recognises 'String' tokens. +string_ :: Lexer Token +string_ = + String <$ char '\"' <*> + (many stringChar <* char '\"' <|> message "unterminated string literal") + +-- | A 'Lexer' that recognises 'Con' tokens. +con_ :: Lexer Token +con_ = (\c cs -> Con (c : cs)) <$> hd <*> tl + where + hd = range ('a', 'z') <|> range ('A', 'Z') + tl = many $ range ('a', 'z') <|> range ('A', 'Z') <|> range ('0', '9') <|> + anyCharFrom "_*+-" + +-- | A 'Lexer' that recognises 'Spec' tokens. +spec_ :: Lexer Token +spec_ = Spec <$> anyCharFrom "()[{]}," + +-- | A 'Lexer' for ATerms. +lexer :: Lexer Token +lexer = layout_ <|> integer_ <|> float_ <|> string_ <|> con_ <|> spec_ + +------------------------------------------------------------------------------- +-- Lexing utilities +------------------------------------------------------------------------------- + +-- | A 'Lexer' for characters that may appear inside a string literal. +stringChar :: Lexer Char +stringChar = range (' ', '!') <|> range ('#', '[') <|> range (']', '\DEL') <|> + escChar + +-- | A 'Lexer' that recognises escaped characters. +escChar :: Lexer Char +escChar = char '\\' *> esc + where + esc = char '\\' <|> char '\"' <|> + '\n' <$ char 'n' <|> '\r' <$ char 'r' <|> '\t' <$ char 't' <|> + (\x y z -> chr (64 * x + 8 * y + z)) <$> + binDigit_ <*> octDigit_ <*> octDigit_ + +-- | A 'Lexer' that recognises a list of signs. +signs :: Lexer [Integer -> Integer] +signs = many (negate <$ char '-') + +-- | A 'Lexer' that recognises a list of digits and tokenises it as an +-- 'Integer'. +digits :: Lexer Integer +digits = foldl (\n i -> 10 * n + toInteger i) 0 <$> some digit_ + +-- | A 'Lexer' that recognises the integer part of an integer or float literal. +integerPart :: Lexer Integer +integerPart = (\fs n -> foldr ($) n fs) <$> signs <*> digits + +-- | A 'Lexer' that recognises the float and standard-form part of a float +-- literal. +floatPart :: Lexer (Integer -> Double) +floatPart = (\flt f n -> f n flt) <$> + (pure "" <|> ((:) <$> char '.' <*> some digit)) <*> sfPart + +-- | A 'Lexer' that recognises the standard-form part of a float literal. +sfPart :: Lexer (Integer -> String -> Double) +sfPart = + (\sf n flt-> read (show n ++ flt ++ sf)) <$> + (pure "" <|> (\c n -> c : show n) <$> anyCharFrom ['e', 'E'] <*> integerPart) + +------------------------------------------------------------------------------- +-- Token Parsers +------------------------------------------------------------------------------- + +-- | A 'Parser' that recognises an integer literal. +integer :: Parser Token Integer +integer = fromInteger <$> satisfy isInteger "literal" + +-- | A 'Parser' that recognises a floating-point literal. +float :: Parser Token Double +float = fromFloat <$> satisfy isFloat "literal" + +-- | A 'Parser' that recognises a string literal. +string :: Parser Token String +string = fromString <$> satisfy isString "literal" + +-- | A 'Parser' that recognises a constructor symbol. +con :: Parser Token Con +con = fromCon <$> satisfy isCon "constructor" + +-- | A 'Parser' that recognises a specified special character. +spec :: Char -> Parser Token Char +spec c = + fromSpec <$> satisfy (\tok -> isSpec tok && fromSpec tok == c) show c diff --git a/src/CCO/Tree/ATerm/Parser.hs b/src/CCO/Tree/ATerm/Parser.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/ATerm/Parser.hs @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.ATerm.Parser +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A 'Parser' for 'ATerm's. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.ATerm.Parser ( + -- * Parser + parser -- :: Component String ATerm +) where + +import CCO.Component (Component) +import qualified CCO.Component as C (parser) +import CCO.Parsing (Parser, eof, (), opt, manySepBy) +import CCO.Tree.ATerm (ATerm (..)) +import CCO.Tree.ATerm.Lexer +import Control.Applicative + +------------------------------------------------------------------------------- +-- Token parsers +------------------------------------------------------------------------------- + +-- | Type of 'Parser's that consume symbols described by 'Token's. +type TokenParser = Parser Token + +------------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------------- + +-- | A 'Component' for parsing 'ATerm's. +parser :: Component String ATerm +parser = C.parser lexer (pATerm <* eof) + +-- | Parses zero or more 'ATerm's separated by commas. +pATerms :: TokenParser [ATerm] +pATerms = manySepBy (spec ',') pATerm + +-- | Parses a single 'ATerm'. +pATerm :: TokenParser ATerm +pATerm = foldl Ann <$> + pBase <*> + many (spec '{' *> pATerms <* spec '}' "annotation") + where + pBase = pInteger <|> pFloat <|> pString <|> pApp <|> pTuple <|> pList + "term" + +-- | Parses an 'Integer'. +pInteger :: TokenParser ATerm +pInteger = Integer <$> integer + +-- | Parses a 'Float'. +pFloat :: TokenParser ATerm +pFloat = Float <$> float + +-- | Parses a 'String'. +pString :: TokenParser ATerm +pString = String <$> string + +-- | Parses an 'App'. +pApp :: TokenParser ATerm +pApp = App <$> con <*> args + where + args = spec '(' *> pATerms <* spec ')' `opt` [] + +-- | Parses a 'Tuple'. +pTuple :: TokenParser ATerm +pTuple = Tuple <$ spec '(' <*> pATerms <* spec ')' + +-- | Parses a 'List'. +pList :: TokenParser ATerm +pList = List <$ spec '[' <*> pATerms <* spec ']' diff --git a/src/CCO/Tree/Base.hs b/src/CCO/Tree/Base.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/Base.hs @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.Base +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A straightforward implementation of the ATerm format for exchanging +-- tree-structured data; see +-- +-- * Mark van den Brand, Hayco de Jong, Paul Klint, and Pieter A. Olivier. +-- Efficient annotated terms. +-- /Software - Practice and Experience (SPE)/, 30(3):259-291, 2000. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.Base ( + -- * The @Tree@ class + Tree (..) +) where + +import CCO.Feedback (Feedback) +import CCO.Tree.ATerm (ATerm (..)) +import CCO.Tree.Parser.Validation (Scheme (ListTerm), validate) + +------------------------------------------------------------------------------- +-- The Tree class +------------------------------------------------------------------------------- + +-- | The 'Tree' class. Instances provide conversions between tree-structured +-- data and the 'ATerm' format. +-- +-- A minimal complete defintion must supply the methods @fromTree@ and +-- @toTree@. +class Tree a where + fromTree :: a -> ATerm -- ^ Retrieves an 'ATerm' from a @Tree@. + toTree :: ATerm -> Feedback a -- ^ Attempts to retrieve a @Tree@ from + -- an 'ATerm'. + + -- | Retrieves an 'ATerm' from a list of @Tree@s. + fromTrees :: [a] -> ATerm + fromTrees xs = List [fromTree x | x <- xs] + + -- | Attempts to retrieve a list of @Tree@s from an 'ATerm'. + toTrees :: ATerm -> Feedback [a] + toTrees (Ann aterm _) = toTrees aterm + toTrees aterm = do validate aterm [ListTerm] + let List aterms = aterm + mapM toTree aterms diff --git a/src/CCO/Tree/Instances.hs b/src/CCO/Tree/Instances.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/Instances.hs @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.Instances +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- 'Tree' instances for types from the Prelude. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.Instances () where + +import CCO.Feedback (Message (Error), errorMessage) +import CCO.Printing +import CCO.Tree.ATerm (ATerm (..), Con) +import CCO.Tree.Base (Tree (..)) +import CCO.Tree.Parser +import Control.Applicative (Applicative (pure, (<*>)), (<$>)) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance Tree Bool where + fromTree False = App "False" [] + fromTree True = App "True" [] + + toTree = parseTree [ app "False" (pure False) + , app "True" (pure True) + ] + +instance Tree a => Tree (Maybe a) where + fromTree Nothing = App "Nothing" [] + fromTree (Just x) = App "Just" [fromTree x] + + toTree = parseTree [ app "Nothing" (pure Nothing) + , app "Just" (Just <$> arg) + ] + +instance (Tree a, Tree b) => Tree (Either a b) where + fromTree (Left x) = App "Left" [fromTree x] + fromTree (Right y) = App "Right" [fromTree y] + + toTree = parseTree [ app "Left" (Left <$> arg) + , app "Right" (Right <$> arg) + ] + +instance Tree Ordering where + fromTree LT = App "LT" [] + fromTree EQ = App "EQ" [] + fromTree GT = App "GT" [] + + toTree = parseTree [ app "LT" (pure LT) + , app "EQ" (pure EQ) + , app "GT" (pure GT) + ] + +instance Tree Char where + fromTree c = String [c] + + toTree aterm = do + s <- parseTree [string] aterm + case s of + [c] -> return c + cs -> errorMessage (ppNonsingletonStringError aterm cs) + + fromTrees s = String s + toTrees = parseTree [string] + +instance Tree Int where + fromTree n = Integer (toInteger n) + toTree = parseTree [fromInteger <$> integer] + +instance Tree Integer where + fromTree n = Integer n + toTree = parseTree [integer] + +instance Tree Float where + fromTree r = Float (realToFrac r) + toTree = parseTree [realToFrac <$> float] + +instance Tree Double where + fromTree r = Float r + toTree = parseTree [float] + +instance Tree a => Tree [a] where + fromTree = fromTrees + toTree = toTrees + +instance (Tree a, Tree b) => Tree (a, b) where + fromTree (x, y) = Tuple [fromTree x, fromTree y] + toTree = parseTree [tuple ((,) <$> arg <*> arg)] + +instance (Tree a, Tree b, Tree c) => Tree (a, b, c) where + fromTree (x, y, z) = Tuple [fromTree x, fromTree y, fromTree z] + toTree = parseTree [tuple ((,,) <$> arg <*> arg <*> arg)] + +instance (Tree a, Tree b, Tree c, Tree d) => Tree (a, b, c, d) where + fromTree (w, x, y, z) = + Tuple [fromTree w, fromTree x, fromTree y, fromTree z] + + toTree = parseTree [tuple ((,,,) <$> arg <*> arg <*> arg <*> arg)] + +instance (Tree a, Tree b, Tree c, Tree d, Tree e) => Tree (a, b, c, d, e) where + fromTree (v, w, x, y, z) = + Tuple [fromTree v, fromTree w, fromTree x, fromTree y, fromTree z] + + toTree = parseTree [tuple ((,,,,) <$> arg <*> arg <*> arg <*> arg <*> arg)] + +instance (Tree a, Tree b, Tree c, Tree d, Tree e, Tree f) => + Tree (a, b, c, d, e, f) where + fromTree (u, v, w, x, y, z) = Tuple [ fromTree u, fromTree v, fromTree w + , fromTree x, fromTree y, fromTree z ] + + toTree = + parseTree [tuple ((,,,,,) <$> arg <*> arg <*> arg <*> arg <*> arg <*> arg)] + +instance (Tree a, Tree b, Tree c, Tree d, Tree e, Tree f, Tree g) => + Tree (a, b, c, d, e, f, g) where + fromTree (t, u, v, w, x, y, z) = Tuple [ fromTree t, fromTree u, fromTree v + , fromTree w, fromTree x, fromTree y + , fromTree z ] + + toTree = parseTree + [tuple ((,,,,,,) <$> arg <*> arg <*> arg <*> arg <*> arg <*> arg <*> arg)] + +instance Tree () where + fromTree _ = Tuple [] + toTree = parseTree [tuple (pure ())] + +------------------------------------------------------------------------------- +-- Pretty printing error messages +------------------------------------------------------------------------------- + +-- | Takes a nonsingleton 'String' and produces an error message indicating +-- that a singleton 'String' in a given 'ATerm' was expected. +ppNonsingletonStringError :: ATerm -> String -> Doc +ppNonsingletonStringError aterm s + = above [ppHeader, ppUnexpected, ppExpected, ppTerm] + where + ppHeader = wrapped ("Error in ATerm.") + ppUnexpected = text "*** Unexpected : " >|< wrapped (describeString s) + ppExpected = text "*** Expected : " >|< wrapped + "singleton string literal" + ppTerm = text "*** In term : " >|< pp aterm + +-- | Retrieves a textual description of a 'String'. +describeString :: String -> String +describeString "" = "empty string literal" +describeString _ = "nonsingleton string literal" diff --git a/src/CCO/Tree/Parser.hs b/src/CCO/Tree/Parser.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/Parser.hs @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.Parser +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A set of simple parsing utilities that facilitate the conversion from +-- 'ATerm's to 'Tree's. +------------------------------------------------------------------------------- + +module CCO.Tree.Parser ( + -- * Parsing ATerms + TreeParser -- abstract, instance: Functor + , integer -- :: TreeParser Integer + , float -- :: TreeParser Double + , string -- :: TreeParser String + , app -- :: Con -> ArgumentParser a -> TreeParser a + , tuple -- :: ArgumentParser a -> TreeParser a + , list -- :: [TreeParser a] -> TreeParser a + , parseTree -- :: [TreeParser a] -> ATerm -> Feedback a + + -- * Parsing arguments + , ArgumentParser -- abstract, instances: Functor, Applicative + , arg -- :: Tree a => ArgumentParser a +) where + +import CCO.Feedback (Feedback, succeeding) +import CCO.Tree.Base (Tree (toTree)) +import CCO.Tree.ATerm (Con, ATerm (..)) +import CCO.Tree.Parser.Validation (Scheme (..), validate) +import Control.Applicative (Applicative (..)) + +------------------------------------------------------------------------------- +-- Parsing ATerms +------------------------------------------------------------------------------- + +infix 4 `app` + +-- | Parser that consumes 'ATerm's and, if successful, produces a value of a +-- specified type. +data TreeParser a = T Scheme (ATerm -> Feedback a) + -- ^ Holds the 'Scheme' of the 'ATerm' to be consumed and + -- the actual parsing function. + +instance Functor TreeParser where + fmap f (T scheme parse) = T scheme (fmap f . parse) + +-- | A 'TreeParser' that consumes an 'Integer' term. +integer :: TreeParser Integer +integer = T IntegerTerm (\(Integer n) -> return n) + +-- | A 'TreeParser' that consumes a 'Float' term. +float :: TreeParser Double +float = T FloatTerm (\(Float r) -> return r) + +-- | A 'TreeParser' that consumes a 'String' term. +string :: TreeParser String +string = T StringTerm (\(String s) -> return s) + +-- | A 'TreeParser' that consumes an application of a given constructor and +-- that uses a specified 'ArgumentParser' to parse the argument terms of the +-- application. +app :: Con -> ArgumentParser a -> TreeParser a +app conid argumentParser = + T (AppTerm conid (arity argumentParser)) $ \(App _ arguments) -> + parseArguments argumentParser arguments + +-- | A 'TreeParser' that consumes a tuple term and that uses a specified +-- 'ArgumentParser' to parse the component terms of the tuple. +tuple :: ArgumentParser a -> TreeParser a +tuple argumentParser = + T (TupleTerm (arity argumentParser)) $ \(Tuple components) -> + parseArguments argumentParser components + +-- | A 'TreeParser' that consumes a list term and that uses a specified +-- family of 'TreeParser's to parse the elements of the list. +list :: [TreeParser a] -> TreeParser [a] +list atermParsers = + T ListTerm $ \(List elements) -> mapM (parseTree atermParsers) elements + +-- | Retrieves the 'Scheme's to be consumed by a given family of +-- 'TreeParser's. +schemes :: [TreeParser a] -> [Scheme] +schemes atermParsers = [scheme | T scheme _ <- atermParsers] + +-- | Uses a family of 'TreeParser's to parse a given 'ATerm'. +parseTree :: [TreeParser a] -> ATerm -> Feedback a +parseTree atermParsers (Ann a _) = parseTree atermParsers a +parseTree atermParsers aterm = do + scheme <- validate aterm (schemes atermParsers) + select [parse aterm | T scheme' parse <- atermParsers, scheme' == scheme] + +------------------------------------------------------------------------------- +-- Parsing arguments +------------------------------------------------------------------------------- + +-- | Parser that consumes a list of 'ATerm's and, if successful, produces a +-- value of a specified type. +data ArgumentParser a = A Int ([ATerm] -> Feedback (a, [ATerm])) + -- ^Holds the number of 'ATerm's to be consumed and + -- the actual parsing function. + +instance Functor ArgumentParser where + fmap f (A n parse) = A n $ \aterms -> do (x, aterms') <- parse aterms + return (f x, aterms') + +instance Applicative ArgumentParser where + pure x = A 0 $ \aterms -> return (x, aterms) + + A m parse <*> A n parse' = A (m + n) $ \aterms -> do + (f, aterms') <- parse aterms + (x, aterms'') <- parse' aterms' + return (f x, aterms'') + +-- | An 'ArgumentParser' that consumes a single 'ATerm', converting it to +-- a 'Tree' of the appropriate type. +arg :: Tree a => ArgumentParser a +arg = A 1 $ \(aterm : aterms) -> do x <- toTree aterm + return (x, aterms) + +-- | Retrieves the number of 'ATerm's to be consumed by a specified +-- 'ArgumentParser'. +arity :: ArgumentParser a -> Int +arity (A n _) = n + +-- | Uses a specified 'ArgumentParser' to parse a list of 'ATerm's. +parseArguments :: ArgumentParser a -> [ATerm] -> Feedback a +parseArguments (A _ parse) = fmap fst . parse + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Selects the first succeeding 'Feedback' computation from a nonempty list. +-- Returns the first computation in the list if all computations in the list +-- are failing. +select :: [Feedback a] -> Feedback a +select us@(v : _) = sel us + where + sel [] = v + sel (u : us) | succeeding u = u + | otherwise = sel us diff --git a/src/CCO/Tree/Parser/Validation.hs b/src/CCO/Tree/Parser/Validation.hs new file mode 100644 --- /dev/null +++ b/src/CCO/Tree/Parser/Validation.hs @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------- +-- | +-- Module : CCO.Tree.Parser.Validation +-- Copyright : (c) 2008 Utrecht University +-- License : All rights reserved +-- +-- Maintainer : stefan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Provides a validator that matches ATerms against schematic descriptions of +-- their structure. +-- +------------------------------------------------------------------------------- + +module CCO.Tree.Parser.Validation ( + -- * Schemes + Scheme (..) + + -- * Validation + , validate +) where + +import CCO.Feedback (Feedback, Message (Error), message) +import CCO.Printing (Doc, above, text, wrapped, (>|<), Printable (pp)) +import CCO.Tree.ATerm (Con, ATerm (..)) +import Data.List (nub, sort) + +------------------------------------------------------------------------------- +-- Schemes +------------------------------------------------------------------------------- + +-- | Describes the top-level shape of an 'ATerm' node. +data Scheme = IntegerTerm -- ^ Integer literal. + | FloatTerm -- ^ Floating-point literal. + | StringTerm -- ^ String literal. + | AppTerm Con Int -- ^ Application of a constructor to a + -- specified number of arguments. + | TupleTerm Int -- ^ Tuple of a specified arity. + | ListTerm -- ^ List. + deriving (Eq) + +-- | Retrieves the scheme of an 'ATerm'. +schemeOf :: ATerm -> Scheme +schemeOf (Integer _) = IntegerTerm +schemeOf (Float _) = FloatTerm +schemeOf (String _) = StringTerm +schemeOf (App conid as) = AppTerm conid (length as) +schemeOf (Tuple as) = TupleTerm (length as) +schemeOf (List _) = ListTerm +schemeOf (Ann a _) = schemeOf a + +-- | An 'ATerm' and its 'Scheme'. +data Focus = ATerm ::: Scheme + +-- | Retrieves the 'Focus' for an 'ATerm'. +focusOn :: ATerm -> Focus +focusOn aterm = aterm ::: schemeOf aterm + +------------------------------------------------------------------------------- +-- Validation +------------------------------------------------------------------------------- + +-- | Validates an 'ATerm' against a family of 'Scheme's and produces the +-- a matching 'Scheme' if one is found. +-- If no matching 'Scheme' was found, an appropriate error message is issued. +validate :: ATerm -> [Scheme] -> Feedback Scheme +validate aterm schemes + | scheme `elem` schemes = return scheme + | otherwise = do message (Error (pp (diagnose focus schemes))) + return scheme + where + focus@(_ ::: scheme) = focusOn aterm + +------------------------------------------------------------------------------- +-- Diagnostics +------------------------------------------------------------------------------- + +-- | Diagnosis of why an 'ATerm' cannot be parsed. +data Diagnosis = NoScheme ATerm + -- ^ There was no 'Scheme' to match the 'ATerm' against. + + | ArityMismatch ATerm Con Int [Int] + -- ^ The arity of an application of a constructor does not + -- match against the arities that were expected for an + -- application of that constructor. + + | SchemeMismatch ATerm Scheme [Scheme] + -- ^ The 'Scheme' of the 'ATerm' does not match against any of + -- the expected 'Scheme's. + +instance Printable Diagnosis where pp = ppDiagnosis + +-- | Takes a 'Focus' and a familiy of 'Scheme's that do not match with it, and +-- produces a 'Diagnosis'. +diagnose :: Focus -> [Scheme] -> Diagnosis + +diagnose (aterm ::: _) [] = NoScheme aterm + +diagnose (aterm ::: scheme@(AppTerm conid arity)) expected + | null expectedArities = SchemeMismatch aterm scheme expected + | otherwise = ArityMismatch aterm conid arity expectedArities + where + expectedArities = + [ expectedArity | + AppTerm conid' expectedArity <- expected, conid' == conid ] + +diagnose (aterm ::: scheme) expected = SchemeMismatch aterm scheme expected + +------------------------------------------------------------------------------- +-- Pretty-printing diagnoses +------------------------------------------------------------------------------- + +-- | Pretty prints an 'Diagnosis'. +ppDiagnosis :: Diagnosis -> Doc + +ppDiagnosis (NoScheme aterm) = above [ppHeader, text " ", ppTerm] + where + ppHeader = wrapped "Error in ATerm." + ppTerm = text "? in term : " >|< pp aterm + +ppDiagnosis (ArityMismatch aterm conid arity expectedArities) + = above [ppHeader, text " ", ppTerm] + where + ppHeader = wrapped $ "Error in ATerm: " ++ conid ++ " " ++ + describeExpectedArities expectedArities ++ + ", but " ++ describeGivenArity arity ++ "." + ppTerm = text "? in term : " >|< pp aterm + +ppDiagnosis (SchemeMismatch aterm scheme expected) + = above [ppHeader, text " ", ppUnexpected, ppExpected, ppTerm] + where + ppHeader = wrapped $ "Error in ATerm." + ppUnexpected = text "? unexpected : " >|< wrapped (describeScheme scheme) + ppExpected = text "? expected : " >|< (wrapped . disjunction) + (map describeScheme expected) + ppTerm = text "? in term : " >|< pp aterm + +-- | Retrieves a textual description of a 'Scheme'. +describeScheme :: Scheme -> String +describeScheme IntegerTerm = "integer literal" +describeScheme FloatTerm = "floating-point literal" +describeScheme StringTerm = "string literal" +describeScheme (AppTerm conid _) = conid +describeScheme (TupleTerm n) = show n ++ "-tuple" +describeScheme ListTerm = "list" + +-- | Retrieves a textual description of an arity given to a constructor +-- application. +-- Produces a phrase like \" were given\". +describeGivenArity :: Int -> String +describeGivenArity 0 = "none were given" +describeGivenArity 1 = "1 was given" +describeGivenArity arity = show arity ++ " were given" + +-- | Retrieves a textual description of the arities expected for a constructor +-- application. +-- Produces a phrase like \"takes arguments\". +describeExpectedArities :: [Int] -> String +describeExpectedArities = descr . sort . nub + where + descr [0] = "takes no arguments" + descr [0, 1] = "takes 0 or 1 argument" + descr arities = "takes " ++ disjunction (map show arities) ++ " arguments" + +-- | Takes a nonempty list of textual items and produces a text that +-- expresses their disjunction: \", , ..., or \". +disjunction :: [String] -> String +disjunction [x] = x +disjunction [x, y] = x ++ " or " ++ y +disjunction [x, y, z] = x ++ ", " ++ y ++ ", or " ++ z +disjunction (x : xs) = x ++ ", " ++ disjunction xs diff --git a/uu-cco.cabal b/uu-cco.cabal new file mode 100644 --- /dev/null +++ b/uu-cco.cabal @@ -0,0 +1,35 @@ +name: uu-cco +version: 0.1.0.0 +synopsis: Utilities for compiler construction +description: A small utility library accompanying the course on + Compiler Construction (INFOMCCO) at Utrecht Univerity. +license: BSD3 +license-file: LICENSE +category: Compilers/Interpreters +copyright: (c) 2008-2014 Utrecht University +author: Stefan Holdermans +maintainer: Atze Dijkstra +stability: provisional +homepage: https://github.com/UU-ComputerScience/uu-cco +build-type: Simple +cabal-version: >= 1.6 +extra-source-files: AUTHORS + +source-repository head + type: git + location: git://github.com/UU-ComputerScience/uu-cco.git + +library + build-depends: base >= 4 && < 5, ansi-terminal >= 0.5.0 + cpp-options: -DCATEGORY + exposed-modules: CCO.Component, CCO.Feedback, CCO.Lexing, CCO.Parsing, + CCO.Printing, CCO.SourcePos, CCO.Tree, CCO.Tree.Parser + other-modules: CCO.Feedback.Message, CCO.Printing.Colour, + CCO.Printing.Doc, CCO.Printing.Printer, + CCO.Printing.Rendering, CCO.Tree.ATerm, + CCO.Tree.ATerm.Lexer, CCO.Tree.ATerm.Parser, + CCO.Tree.Base, CCO.Tree.Instances, + CCO.Tree.Parser.Validation + extensions: CPP, RankNTypes + hs-source-dirs: src +