uu-cco (empty) → 0.1.0.0

raw patch · 23 files changed

+3100/−0 lines, 23 filesdep +ansi-terminaldep +basesetup-changed

Dependencies added: ansi-terminal, base

Files

• AUTHORS +2/−0
• LICENSE +1/−0
• Setup.lhs +4/−0
• src/CCO/Component.hs +108/−0
• src/CCO/Feedback.hs +126/−0
• src/CCO/Feedback/Message.hs +79/−0
• src/CCO/Lexing.hs +380/−0
• src/CCO/Parsing.hs +352/−0
• src/CCO/Printing.hs +468/−0
• src/CCO/Printing/Colour.hs +33/−0
• src/CCO/Printing/Doc.hs +43/−0
• src/CCO/Printing/Printer.hs +157/−0
• src/CCO/Printing/Rendering.hs +330/−0
• src/CCO/SourcePos.hs +61/−0
• src/CCO/Tree.hs +35/−0
• src/CCO/Tree/ATerm.hs +98/−0
• src/CCO/Tree/ATerm/Lexer.hs +185/−0
• src/CCO/Tree/ATerm/Parser.hs +79/−0
• src/CCO/Tree/Base.hs +52/−0
• src/CCO/Tree/Instances.hs +154/−0
• src/CCO/Tree/Parser.hs +146/−0
• src/CCO/Tree/Parser/Validation.hs +172/−0
• uu-cco.cabal +35/−0

@@ -0,0 +1,2 @@+Stefan Holdermans <stefan@holdermans.nl> (Original author)+Atze Dijkstra <atze@uu.nl> (Maintainer)

@@ -0,0 +1,1 @@+Copyright (c) 2008-2014 Utrecht University. All rights reserved.

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

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

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

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

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

@@ -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 +++                                                   ":<at end of file>"+describeSourcePos (SourcePos Stdin (Pos ln col)) = "line " ++ show ln +++                                                   ":column " ++ show col+describeSourcePos (SourcePos Stdin EOF)          = "<at end of input>"++-- | 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: \"<item>, <item>, ..., or <item>\".+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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -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 \"<arity> 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 <arity> 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: \"<item>, <item>, ..., or <item>\".+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

@@ -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 <stefan@holdermans.nl>+maintainer:            Atze Dijkstra <atze@uu.nl>+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+