packages feed

mpretty (empty) → 0.1.0.0

raw patch · 13 files changed

+945/−0 lines, 13 filesdep +ansi-terminaldep +basedep +containerssetup-changed

Dependencies added: ansi-terminal, base, containers, data-lens-fd, data-lens-template, mtl, orders, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, David Darais++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of David Darais nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,84 @@+module Test where++import Prelude hiding ((.))+import Control.Category+import Text.MPretty+import qualified Data.Text.Lazy.IO as T+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import Data.Map (Map)+import Util.Lens+import Data.Lens+import Control.Monad.Reader+import Util.HasLens++e1 :: [[Map String [Integer]]]+e1 =+  [ [ Map.fromList +      [ ("foo", [1111,1112,1113,1114])+      , ("bar", [2222,2223,2224])+      , ("baz", [3333,3334])+      ]+    , Map.empty+    , Map.fromList+      [ ("foo", [4444,4443,4442,4441])+      , ("bar", [5555,5554,5553,5552,5551])+      ]+    ]+  , [ Map.empty+    , Map.fromList+      [ ("foo", [6666,6667,6668,6669])+      , ("bar", [7777,7778,7779])+      ]+    ]+  , []+  , [ Map.fromList+      [ ("foo", [8888,8889])+      , ("bar", [9999])+      , ("baz", [])+      ]+    , Map.empty+    ]+  ]++data Exp = Var String | App Exp Exp | Dollar Exp Exp | Compose Exp Exp | Plus Exp Exp | Minus Exp Exp++instance IsPretty Exp where+  pretty (Var x) = text $ pString x+  pretty (App e1 e2) =+    infixOp LeftD 10 NoBuffer (text $ pString " ") (pretty e1) (pretty e2)+  pretty (Dollar e1 e2) = +    infixOp RightD 1 Buffer (text $ pString "$") (pretty e1) (pretty e2)+  pretty (Compose e1 e2) =+    infixOp RightD 9 Buffer (text $ pString ".") (pretty e1) (pretty e2)+  pretty (Plus e1 e2) =+    infixOp LeftD 5 Buffer (text $ pString "+") (pretty e1) (pretty e2)+  pretty (Minus e1 e2) =+    infixOp RightD 5 Buffer (text $ pString "-") (pretty e1) (pretty e2)++e2 :: Exp+e2 = Dollar (Var "x") $ Compose (Var "y") $ Dollar (App (App (Var "l") $ Var "z") $ Var "q") $ Var "m"++e3 :: Exp+e3 = Plus (Plus (Var "x") (Var "y")) (Plus (Var "z") (Var "a"))++e4 :: Exp+e4 = Minus (Minus (Var "x") (Var "y")) (Minus (Var "z") (Var "a"))++e5 :: Exp+e5 = Minus (Plus (Var "x") (Var "y")) (Plus (Var "z") (Var "a"))++e6 :: Exp+e6 = Plus (Minus (Var "x") (Var "y")) (Minus (Var "z") (Var "a"))++main :: IO ()+main = do+  T.putStrLn $ execPretty $ styleVariants $ layoutWidth 5 $ pretty e1+  T.putStrLn $ execPretty $ showStyle $ pretty e1+  T.putStrLn $ execPretty $ group $ layoutWidth 5 $ pretty e2+  T.putStrLn $ execPretty $ styleVariants $ layoutWidth 5 $ pretty e2+  T.putStrLn $ execPretty $ pretty e3+  T.putStrLn $ execPretty $ pretty e4+  T.putStrLn $ execPretty $ pretty e5+  T.putStrLn $ execPretty $ pretty e6
+ Text/MPretty.hs view
@@ -0,0 +1,11 @@+module Text.MPretty+  ( module Text.MPretty.IsPretty+  , module Text.MPretty.MonadPretty+  , module Text.MPretty.Pretty+  , module Text.MPretty.StateSpace+  ) where++import Text.MPretty.IsPretty+import Text.MPretty.MonadPretty+import Text.MPretty.Pretty+import Text.MPretty.StateSpace
+ Text/MPretty/IsPretty.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts #-}++module Text.MPretty.IsPretty where++import Text.MPretty.Pretty+import Data.Monoid+import Data.Map (Map)+import Data.Set (Set)+import Text.MPretty.MonadPretty+import Text.MPretty.StateSpace+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T++class IsPretty t where+  pretty :: (MonadPretty env out state m) => t -> m ()+  prettyDropIndent :: (MonadPretty env out state m) => t -> m ()+  prettyDropIndent = dropIndent . pretty+  prettyList :: (MonadPretty env out state m) => [t] -> m ()+  prettyList = +    encloseSep (pString "[") (pString "]") (pString ",") +    . map pretty+  prettyDropIndentList :: (MonadPretty env out state m) => [t] -> m ()+  prettyDropIndentList =+    encloseSepDropIndent (pString "[") (pString "]") (pString ",")+    . map pretty++instance IsPretty Bool where+  pretty = literal . string . show++instance IsPretty Int where+  pretty = literal . string . show++instance IsPretty Integer where+  pretty = literal . string . show++instance IsPretty Double where+  pretty = literal . string . show++instance IsPretty Char where+  pretty = literal . string . show+  prettyList = literal . string . ($ []) . showList+  prettyDropIndentList = dropIndent . prettyList++instance IsPretty () where+  pretty () = punctuation $ string "()"+instance (IsPretty a, IsPretty b) => IsPretty (a,b) where+  pretty (a,b) = encloseSep (pString "(") (pString ")") (pString ",") +    [pretty a, pretty b]+instance (IsPretty a, IsPretty b, IsPretty c) => IsPretty (a,b,c) where+  pretty (a,b,c) = encloseSep (pString "(") (pString ")") (pString ",") +    [pretty a, pretty b, pretty c]+instance (IsPretty a, IsPretty b, IsPretty c, IsPretty d) => IsPretty (a,b,c,d) where+  pretty (a,b,c,d) = encloseSep (pString "(") (pString ")") (pString ",")+    [pretty a, pretty b, pretty c, pretty d]++instance (IsPretty a) => IsPretty [a] where+  pretty = prettyList+  prettyDropIndent = prettyDropIndentList++instance (IsPretty a) => IsPretty (Set a) where+  pretty = +    encloseSep (pString "{") (pString "}") (pString ",") +    . map pretty+    . Set.toList+  prettyDropIndent =+    encloseSepDropIndent (pString "{") (pString "}") (pString ",")+    . map pretty+    . Set.toList++instance (IsPretty k, IsPretty v) => IsPretty (Map k v) where+  pretty = +    encloseSep (pString "{") (pString "}") (pString ",") +    . map prettyMapping+    . Map.toList+  prettyDropIndent =+    encloseSepDropIndent (pString "{") (pString "}") (pString ",")+    . map prettyMapping+    . Map.toList++prettyMapping :: (MonadPretty env out state m, IsPretty k, IsPretty v) => (k,v) -> m ()+prettyMapping (k,v) = group $ hsep+  [ pretty k+  , punctuation $ string "=>"+  , prettyDropIndent v+  ]++showFromPretty :: (IsPretty a) => a -> String+showFromPretty = T.unpack . execPretty . showStyle . pretty++----- IO -----++ipPrint :: (IsPretty a) => a -> IO ()+ipPrint = T.putStr . execPretty . pretty++ipPrintLn :: (IsPretty a) => a -> IO ()+ipPrintLn = T.putStrLn . execPretty . pretty
+ Text/MPretty/MonadPretty.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TemplateHaskell, ConstraintKinds, FlexibleContexts #-}++module Text.MPretty.MonadPretty where++import Prelude hiding (id, (.))++import Data.PartialOrder+import qualified Data.List as L+import Data.Char+import Control.Category+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Data.Lens+import System.Console.ANSI+import Text.MPretty.StateSpace+import Util.ConsoleState+import Util.HasLens+import Util.Lens+import Util.List++----- "Primitives" -----++text :: (MonadPretty env out state m) => out -> m ()+text s = +  let sL = pLength s+      nsL = countNonSpace s+  in do+    tell s+    columnL . view %= (+) sL+    ribbonL . view %= (+) nsL+    m <- look $ failureL . view+    when (m == Fail) $ do+      w <- look $ layoutWidthL . view+      rr <- look $ ribbonRatioL . view+      k <- access $ columnL . view+      r <- access $ ribbonL . view+      when (k > w) mzero+      when (fromIntegral r > fromIntegral w * rr) mzero+    where+      countNonSpace = pFoldl (\i c -> i + if isSpace c then 0 else 1) 0++string :: (MonadPretty env out state m) => String -> m ()+string = text . pString++space :: (MonadPretty env out state m) => Int -> m ()+space = string . flip replicate ' '++tryFlat :: (MonadPretty env out state m) => m a -> m a -> m a+tryFlat dFlat dBreak = do+  l <- look $ layoutL . view+  case l of+    Flat -> dFlat+    Break -> dBreak++hardLine :: (MonadPretty env out state m) => m ()+hardLine = do+  i <- look $ nestingL . view+  tell $ pString "\n"+  columnL . view ~= 0+  ribbonL . view ~= 0+  space i++flatFail :: (MonadPretty env out state m) => m a -> m a+flatFail = +  local (modL (failureL . view) $ const Fail) +  . local (modL (layoutL . view) $ const Flat)++nest :: (MonadPretty env out state m) => Int -> m a -> m a+nest i = local $ modL (nestingL . view) (i +)++group :: (MonadPretty env out state m) => m a -> m a+group aM = do+  l <- look $ layoutL . view+  case l of+    Flat -> aM+    Break -> msum+      [ flatFail aM+      , aM+      ]++align :: (MonadPretty env out state m) => m a -> m a+align aM = do+  i <- look $ nestingL . view+  k <- access $ columnL . view+  nest (k-i) aM++hang :: (MonadPretty env out state m) => Int -> m a -> m a+hang i = align . nest i++precedence :: (MonadPretty env out state m) => (Precedence,Precedence) -> m a -> m a+precedence = local . setL (precedenceL . view)++style :: (MonadPretty env out state m) => Style -> m a -> m a+style = local . setL (styleL . styleOptionsL . view)++buffering :: (MonadPretty env out state m) => Buffering -> m a -> m a+buffering = local . setL (bufferingL . styleOptionsL . view)++doConsole :: (MonadPretty env out state m) => Bool -> m a -> m a+doConsole = local . setL (doConsoleL . view)++layoutWidth :: (MonadPretty env out state m) => Int -> m a -> m a+layoutWidth = local . setL (layoutWidthL . view)++indentWidth :: (MonadPretty env out state m) => Int -> m a -> m a+indentWidth = local . setL (indentWidthL . styleOptionsL . view)++----- Helpers -----++buffer :: (MonadPretty env out state m) => m a -> m a+buffer = buffering Buffer++noBuffer :: (MonadPretty env out state m) => m a -> m a+noBuffer = buffering NoBuffer++console :: (MonadPretty env out state m) => m a -> m a+console = doConsole True++noConsole :: (MonadPretty env out state m) => m a -> m a+noConsole = doConsole False++closedPrecedence :: Int -> (Precedence,Precedence)+closedPrecedence i = (Precedence i NoD False,Precedence i NoD False)++getBuff :: (MonadPretty env out state m) => m out+getBuff = do+  b <- look $ bufferingL . styleOptionsL . view+  return $ case b of+    Buffer -> pString " "+    NoBuffer -> mempty++----- Style helpers -----++dropIndent :: (MonadPretty env out state m) => m () -> m ()+dropIndent d = do+  i <- look $ indentWidthL . styleOptionsL . view+  tryFlat (return ()) $ do+    hardLine+    space i+  align d++encloseSepPre :: (MonadPretty env out state m)+              => out -> out -> out -> Bool -> [m ()] -> m ()+encloseSepPre lbrac rbrac sep snug ds = +  let lbracL = pLength lbrac+      sepL = pLength sep+  in do+    buff <- getBuff+    let f = foldr (.) id+          [ mapFirst $ \ d -> do+              punctuation $ text lbrac+              tryFlat (text buff) $ do +                space $ sepL - lbracL+                text buff+              d+          , mapRest $ \ d -> do+              tryFlat (text buff) $ do+                hardLine+                space $ lbracL - sepL+              punctuation $ text sep+              text buff+              d+          , mapLast $ \ d -> do+              d+              if snug then text buff else tryFlat (text buff) hardLine+              punctuation $ text rbrac+          ]+    group . sequence_ . f $ map (precedence (closedPrecedence 0)  . align) ds++encloseSepPost :: (MonadPretty env out state m)+               => out -> out -> out -> [m ()] -> m ()+encloseSepPost lbrac rbrac sep ds =+  let lbracL = pLength lbrac+  in do+    buff <- getBuff+    let f = foldr (.) id $+          [ mapFirst $ \ d -> do+              punctuation $ text lbrac+              text buff+              d+          , mapRest $ \ d -> do+              tryFlat (return ()) $ do+                hardLine+                space lbracL+              text buff+              d+          , mapLeading $ \ d -> do+              d+              text buff+              punctuation $ text sep+          , mapLast $ \ d -> do+              d+              text buff+              punctuation $ text rbrac+          ]+    group . sequence_ . f $ map (precedence (closedPrecedence 0) . align) ds++encloseSepIndent :: (MonadPretty env out state m)+                 => out -> out -> out -> [m ()] -> m ()+encloseSepIndent lbrac rbrac sep ds = do+  buff <- getBuff+  i <- look $ indentWidthL . styleOptionsL . view+  let f = foldr (.) id $+        [ mapFirst $ \ d -> do+            punctuation $ text lbrac+            d+        , map $ \ d -> do+            tryFlat (text buff) $ do+              hardLine+              space i+            d+        , mapLeading $ \ d -> do+            d+            text buff+            punctuation $ text sep+        , mapLast $ \ d -> do+            d+            tryFlat (text buff) hardLine+            punctuation $ text rbrac+        ]+  group . sequence_ . f $ map (precedence (closedPrecedence 0) . align) ds++encloseSep :: (MonadPretty env out state m) +           => out -> out -> out -> [m ()] -> m ()+encloseSep lbrac rbrac _ [] = punctuation $ text lbrac >> text rbrac+encloseSep lbrac rbrac sep ds = do+  s <- look $ styleL . styleOptionsL . view+  case s of+    PreAlignStyle -> encloseSepPre lbrac rbrac sep False ds+    PreSnugStyle -> encloseSepPre lbrac rbrac sep True ds+    PostStyle -> encloseSepPost lbrac rbrac sep ds+    IndentStyle -> encloseSepIndent lbrac rbrac sep ds++encloseSepDropIndent :: (MonadPretty env out state m)+                     => out -> out -> out -> [m ()] -> m ()+encloseSepDropIndent lbrac rbrac _ [] = punctuation $ text lbrac >> text rbrac+encloseSepDropIndent lbrac rbrac sep ds = do+  s <- look $ styleL . styleOptionsL . view+  case s of+    PreAlignStyle -> dropIndent $ encloseSepPre lbrac rbrac sep False ds+    PreSnugStyle -> dropIndent $ encloseSepPre lbrac rbrac sep True ds+    PostStyle -> dropIndent $ encloseSepPost lbrac rbrac sep ds+    IndentStyle -> encloseSepIndent lbrac rbrac sep ds++infixOp :: (MonadPretty env out state m) +        => Direction -> Int -> Buffering -> m () -> m () -> m () -> m ()+infixOp d n b infixD leftD rightD = do+  s <- look $ styleL . styleOptionsL . view+  let buff = case b of+        Buffer -> pString " "+        NoBuffer -> mempty+  (pl,pr) <- look $ precedenceL . view+  let q = Precedence n d False+      ql = if d == LeftD then q else pbump q+      qr = if d == RightD then q else pbump q+      enclose = if lte pl q && lte pr q+        then id+        else group . parenthesize+  enclose $ do+    (pl',pr') <- look $ precedenceL . view+    precedence (pl',ql) leftD+    let preSep = do+          tryFlat (text buff) hardLine+          infixD+          text buff+        postSep = do+          text buff+          infixD+          tryFlat (text buff) hardLine+    case s of+      PreAlignStyle -> preSep+      PreSnugStyle -> preSep+      PostStyle -> postSep+      IndentStyle -> postSep+    precedence (qr,pr') rightD++hsep :: (MonadPretty env out state m) => [m ()] -> m ()+hsep ds = do+  buff <- getBuff+  foldr (>>) (return ()) $ L.intersperse (text buff) ds++vsep :: (MonadPretty env out state m) => [m ()] -> m ()+vsep ds = do+  buff <- getBuff+  foldr (>>) (return ()) $ L.intersperse (tryFlat (text buff) hardLine) ds++parenthesize :: (MonadPretty env out state m) => m () -> m ()+parenthesize d = do+  punctuation $ string "("+  precedence (closedPrecedence 0) $ align d+  punctuation $ string ")"++sexpListCons :: (MonadPretty env out state m) => [m ()] -> Maybe (m ()) -> m ()+sexpListCons ds dM = group $ parenthesize $ do+  buffer $ vsep $ ds+  case dM of+    Nothing -> return ()+    Just d -> do+      tryFlat (space 1) hardLine+      punctuation $ string ". "+      d++sexpList :: (MonadPretty env out state m) => [m ()] -> m ()+sexpList = flip sexpListCons Nothing++-- a pretty-printing mode suitable for providing a Show instance++showStyle :: (MonadPretty env out state m) => m a -> m a+showStyle = +  layoutWidth 0 +  . local (setL (layoutL . view) Flat) +  . noBuffer +  . noConsole++----- ANSI Console helpers -----++emitConsoleStateCodes :: (MonadPretty env out state m) => m ()+emitConsoleStateCodes = do+  proceed <- look $ doConsoleL . view+  when proceed $ do+    cs <- look $ consoleStateL . view+    tell $ pString $ setConsoleStateCodes cs++localConsole :: (MonadPretty env out state m) => (ConsoleState -> ConsoleState) -> m a -> m a+localConsole f aM = do+  a <- local (modL (consoleStateL . view) f) $ do+    emitConsoleStateCodes+    aM+  emitConsoleStateCodes+  return a++intensity :: (MonadPretty env out state m) => ConsoleIntensity -> m a -> m a+intensity = localConsole . setL intensityML . Just++italicized :: (MonadPretty env out state m) => Bool -> m a -> m a+italicized = localConsole . setL italicizedML . Just++underlining :: (MonadPretty env out state m) => Underlining -> m a -> m a+underlining = localConsole . setL underliningML . Just++blinkSpeed :: (MonadPretty env out state m) => BlinkSpeed -> m a -> m a+blinkSpeed = localConsole . setL blinkSpeedML . Just++visible :: (MonadPretty env out state m) => Bool -> m a -> m a+visible = localConsole . setL visibleML . Just++swapFgBg :: (MonadPretty env out state m) => Bool -> m a -> m a+swapFgBg = localConsole . setL swapFgBgML . Just++gcolor :: (MonadPretty env out state m) => ConsoleLayer -> ColorIntensity -> Color -> m a -> m a+gcolor cl ci c = localConsole $ setL gcolorML $ Just (cl,ci,c)++color :: (MonadPretty env out state m) => ColorIntensity -> Color -> m a -> m a+color = gcolor Foreground++localStyle :: (MonadPretty env out state m) => Lens Palette ConsoleState -> m a -> m a+localStyle l aM = do+  c <- look $ l . paletteL . view+  localConsole (mappend c) aM++punctuation :: (MonadPretty env out state m) => m a -> m a+punctuation = localStyle punctuationColorL++literal :: (MonadPretty env out state m) => m a -> m a+literal = localStyle literalColorL++binder :: (MonadPretty env out state m) => m a -> m a+binder = localStyle binderColorL++keyword :: (MonadPretty env out state m) => m a -> m a+keyword = localStyle keywordColorL++classifier :: (MonadPretty env out state m) => m a -> m a+classifier = localStyle classifierColorL++----- Testing -----++styleVariants :: (MonadPretty env out state m) => m () -> m ()+styleVariants aM = do+  i <- look $ indentWidthL . styleOptionsL . view+  let configs =+        [ StyleOptions PreAlignStyle Buffer   i+        , StyleOptions PreAlignStyle NoBuffer i+        , StyleOptions PreSnugStyle  Buffer   i+        , StyleOptions PreSnugStyle  NoBuffer i+        , StyleOptions PostStyle     Buffer   i+        , StyleOptions PostStyle     NoBuffer i+        , StyleOptions IndentStyle   Buffer   i+        , StyleOptions IndentStyle   NoBuffer i+        ]+  forM_ configs $ \ o -> do+    hardLine+    string "##### "+    string $ show o+    string " #####"+    hardLine+    local (setL (styleOptionsL . view) o) aM+    hardLine
+ Text/MPretty/Pretty.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Text.MPretty.Pretty where++import Data.Maybe+import Text.MPretty.StateSpace+import Control.Monad.RWS+import Data.Text.Lazy (Text)+import Util.ConsoleState+import Text.MPretty.MonadPretty++newtype Pretty a = Pretty +  { unPretty :: RWST PrettyEnv Text PrettyState [] a }+  deriving +  ( Monad+  , MonadReader PrettyEnv+  , MonadWriter Text+  , MonadState PrettyState+  , MonadPlus+  )++runPretty :: Pretty a -> PrettyEnv -> PrettyState -> [(a,PrettyState,Text)]+runPretty aM r s = runRWST (unPretty aM) r s++execPretty :: Pretty () -> Text+execPretty aM =+  let aM' = emitConsoleStateCodes >> group aM+      ((),_,t) = head $ runPretty aM' defaultPrettyEnv defaultPrettyState+  in t
+ Text/MPretty/StateSpace.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ConstraintKinds  #-}++module Text.MPretty.StateSpace where++import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Reader+import Data.Function+import Data.PartialOrder+import Data.List+import System.Console.ANSI+import Data.Monoid+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Util.ConsoleState+import Data.Lens.Template+import Data.Lens+import Util.HasLens++class (Monoid out) => PrettyOutput out where+  pString :: String -> out+  pLength :: out -> Int+  pFoldl :: (a -> Char -> a) -> a -> out -> a++instance PrettyOutput String where+  pString = id+  pLength = length+  pFoldl = foldl'++instance PrettyOutput Text where+  pString = T.pack+  pLength = fromIntegral . T.length+  pFoldl = T.foldl'++data Layout = Flat | Break+  deriving (Eq, Ord, Show, Enum)+data Failure = Fail | NoFail+  deriving (Eq, Ord, Show, Enum)++data Style = PreAlignStyle | PreSnugStyle | PostStyle | IndentStyle+  deriving (Eq, Ord, Show, Enum)+data Buffering = Buffer | NoBuffer+  deriving (Eq, Ord, Show, Enum)++data Direction = NoD | LeftD | RightD+  deriving (Eq, Show, Enum)++instance PartialOrder Direction where+  lte NoD _ = True+  lte _ NoD = False+  lte LeftD LeftD = True+  lte LeftD RightD = False+  lte RightD LeftD = False+  lte RightD RightD = True+  +data Precedence = Precedence Int Direction Bool+  deriving (Eq, Show)++instance PartialOrder Precedence where+  pcompare = pcompare `on` toAlg+    where+    toAlg (Precedence n d b) = ((n,d),b)++pbump :: Precedence -> Precedence+pbump (Precedence n k b) = Precedence n k True++data StyleOptions = StyleOptions+  { _styleL :: Style+  , _bufferingL :: Buffering+  , _indentWidthL :: Int+  } deriving (Eq, Ord, Show)+makeLens ''StyleOptions++defaultPreOptions :: StyleOptions+defaultPreOptions = StyleOptions PreAlignStyle Buffer 2++defaultPostOptions :: StyleOptions+defaultPostOptions = StyleOptions PostStyle NoBuffer 2++defaultIndentStyle :: StyleOptions+defaultIndentStyle = StyleOptions IndentStyle NoBuffer 2++data Palette = Palette+  { _punctuationColorL :: ConsoleState+  , _literalColorL :: ConsoleState+  , _binderColorL :: ConsoleState+  , _keywordColorL :: ConsoleState+  , _classifierColorL :: ConsoleState+  } deriving (Eq, Ord, Show)+makeLens ''Palette++defaultPalette :: Palette+defaultPalette = Palette+  { _punctuationColorL = setConsoleColor Dull Yellow+  , _literalColorL = setConsoleColor Dull Red+  , _binderColorL = setConsoleColor Dull Cyan+  , _keywordColorL = +      setConsole underliningML SingleUnderline+      `mappend` setConsole intensityML BoldIntensity+  , _classifierColorL = setConsoleColor Dull Magenta+  }++data PrettyEnv = PrettyEnv+  -- layout options+  { _layoutWidthL :: Int+  , _ribbonRatioL :: Double+  -- dynamic environment+  , _nestingL :: Int+  , _layoutL :: Layout+  , _failureL :: Failure+  -- , _depth :: Int+  , _precedenceL :: (Precedence,Precedence)+  -- style+  , _styleOptionsL :: StyleOptions+  -- truncation+  -- , _truncateDepth :: Int+  -- , _truncate :: Bool+  -- console+  , _paletteL :: Palette+  , _consoleStateL :: ConsoleState+  , _doConsoleL :: Bool+  } deriving (Eq, Show)+makeLens ''PrettyEnv++defaultPrettyEnv :: PrettyEnv+defaultPrettyEnv = PrettyEnv+  { _layoutWidthL = 80+  , _ribbonRatioL = 0.8+  , _nestingL = 0+  , _layoutL = Break+  , _failureL = NoFail+  , _precedenceL = (Precedence 0 NoD False,Precedence 0 NoD False)+  , _styleOptionsL = defaultPreOptions+  , _paletteL = defaultPalette+  , _consoleStateL = emptyConsoleState+  , _doConsoleL = True+  }++instance HasLens PrettyEnv PrettyEnv where+  view = iso id id++data PrettyState = PrettyState+  { _columnL :: Int+  , _ribbonL :: Int+  } deriving (Eq, Ord, Show)+makeLens ''PrettyState++defaultPrettyState :: PrettyState+defaultPrettyState = PrettyState+  { _columnL = 0 +  , _ribbonL = 0+  }++instance HasLens PrettyState PrettyState where+  view = iso id id++type (MonadRWS env out state m) =+  ( MonadReader env m+  , MonadWriter out m+  , MonadState state m+  )++type (MonadPretty env out state m) = +  ( MonadRWS env out state m+  , MonadPlus m+  , HasLens env PrettyEnv+  , PrettyOutput out+  , HasLens state PrettyState+  )
+ Util/ConsoleState.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}++module Util.ConsoleState where++import Data.Monoid+import System.Console.ANSI+import Data.Lens.Template+import Data.Maybe+import Control.Monad+import Data.Lens++data ConsoleState = ConsoleState+  { _intensityML :: Maybe ConsoleIntensity+  , _italicizedML :: Maybe Bool+  , _underliningML :: Maybe Underlining+  , _blinkSpeedML :: Maybe BlinkSpeed+  , _visibleML :: Maybe Bool+  , _swapFgBgML :: Maybe Bool+  , _gcolorML :: Maybe (ConsoleLayer,ColorIntensity,Color)+  } deriving (Eq, Ord, Show)+makeLens ''ConsoleState++emptyConsoleState :: ConsoleState+emptyConsoleState = +  ConsoleState Nothing Nothing Nothing Nothing Nothing Nothing Nothing++instance Monoid ConsoleState where+  mempty = emptyConsoleState+  mappend cs1 cs2 =+    let ConsoleState iy1 it1 u1 b1 v1 s1 g1 = cs1+        ConsoleState iy2 it2 u2 b2 v2 s2 g2 = cs2+    in ConsoleState (mplus iy1 iy2) (mplus it1 it2) (mplus u1 u2) +         (mplus b1 b2) (mplus v1 v2) (mplus s1 s2) (mplus g1 g2)++setConsole :: Lens ConsoleState (Maybe a) -> a -> ConsoleState+setConsole l x = setL l (Just x) emptyConsoleState++setConsoleColor :: ColorIntensity -> Color -> ConsoleState+setConsoleColor ci c = setConsole gcolorML (Foreground,ci,c)++setConsoleStateCodes :: ConsoleState -> String+setConsoleStateCodes cs =+  setSGRCode $ Reset : catMaybes+    [ fmap SetConsoleIntensity $ _intensityML cs+    , fmap SetItalicized $ _italicizedML cs+    , fmap SetUnderlining $ _underliningML cs+    , fmap SetBlinkSpeed $ _blinkSpeedML cs+    , fmap SetVisible $ _visibleML cs+    , fmap SetSwapForegroundBackground $ _swapFgBgML cs+    , fmap (\(cl,ci,c) -> SetColor cl ci c) $ _gcolorML cs+    ]
+ Util/HasLens.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Util.HasLens where++import Data.Lens++class HasLens a b where+  view :: Lens a b
+ Util/Lens.hs view
@@ -0,0 +1,8 @@+module Util.Lens where++import Control.Monad.Reader+import Data.Lens++look :: (MonadReader env m) => Lens env b -> m b+look l = liftM (getL l) ask+
+ Util/List.hs view
@@ -0,0 +1,19 @@+module Util.List where++mapFirst :: (a -> a) -> [a] -> [a]+mapFirst f [] = []+mapFirst f (x:xs) = f x:xs++mapRest :: (a -> a) -> [a] -> [a]+mapRest f [] = []+mapRest f (x:xs) = x:map f xs++mapLast :: (a -> a) -> [a] -> [a]+mapLast f [] = []+mapLast f [x] = [f x]+mapLast f (x:xs) = x:mapLast f xs++mapLeading :: (a -> a) -> [a] -> [a]+mapLeading f [] = []+mapLeading f [x] = [x]+mapLeading f (x:xs) = f x:mapLeading f xs
+ mpretty.cabal view
@@ -0,0 +1,36 @@+name:                mpretty+synopsis:            a monadic, extensible pretty printing library+description:         based on wadler-leijen printing.  supports ansi colors,+                     configurable list printing styles, and extension of the printing monad+version:             0.1.0.0+license:             BSD3+license-file:        LICENSE+author:              David Darais+maintainer:          david.darais@gmail.com+category:            Text+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     Text.MPretty+                       , Text.MPretty.IsPretty+                       , Text.MPretty.MonadPretty+                       , Text.MPretty.Pretty+                       , Text.MPretty.StateSpace++  other-modules:       +                       Util.ConsoleState+                     , Util.HasLens+                     , Util.Lens+                     , Util.List+                     , Test++  build-depends:       ansi-terminal == 0.6.*+                     , base == 4.6.*+                     , containers == 0.5.*+                     , data-lens-fd == 2.0.*+                     , data-lens-template == 2.1.*+                     , mtl == 2.1.*+                     , text == 0.11.*+                     , transformers == 0.3.*+                     , orders == 0.1.*