Pretty.hs

{-# LANGUAGE FlexibleInstances, DefaultSignatures, UndecidableInstances
    , OverloadedStrings #-}
{-|
  Module      : Text.ANTLR.Pretty
  Description : A pretty-printing type class to be used across antlr-haskell modules
  Copyright   : (c) Karl Cronburg, 2018
  License     : BSD3
  Maintainer  : karl@cs.tufts.edu
  Stability   : experimental
  Portability : POSIX

  I want to have something like Show whereby every time I add a new type to the
  system, I can implement a function that gets called by existing code which
  happens to have types that get parametrized by that type. I don't want to
  modify an existing file / centralizing all of the types in my system into a
  single file makes little sense because then that one file becomes a hub /
  single point of failure.

  * I need a typeclass (no modifying existing files, but they need to call my
  new code without passing around a new show function)

  * The prettify function of that typeclass needs to return a state monad so
  that recursive calls keep the state

  * A pshow function needs to evalState on the prettify function with an
  initial indentation of zero (along with any other future state values...)

-}
module Text.ANTLR.Pretty where
import Control.Monad.Trans.State.Lazy
import qualified Data.Map.Strict as M
import Data.Data (toConstr, Data(..))

import qualified Data.Text as T

-- | Pretty-printing state
data PState = PState
  { indent   :: Int     -- ^ current indentation level
  , vis_chrs :: Int     -- ^ number of visible characters consumed so far
  , str :: T.Text       -- ^ the string, 'T.Text', that we've constructed so far
  , columns_soft :: Int -- ^ soft limit on number of columns to consume per row
  , columns_hard :: Int -- ^ hard limit on number of columns to consume per row
  , curr_col :: Int     -- ^ column number we're on in the current row of 'str'
  , curr_row :: Int     -- ^ number of rows (newlines) we've printed to 'str'
  }

-- | The pretty state monad
type PrettyM val = State PState val

-- | No value being threaded through the monad (because result is in 'str')
type Pretty = PrettyM ()

-- | Define the 'Prettify' type class for your pretty-printable type @t@.
class Prettify t where
  {-# MINIMAL prettify #-}

  -- | Defines how to pretty-print some type.
  prettify :: t -> Pretty
  default prettify :: (Show t) => t -> Pretty
  prettify = rshow

  -- | Lists are pretty-printed specially.
  prettifyList :: [t] -> Pretty
  prettifyList = prettifyList_

-- | Initial Pretty state with safe soft and hard column defaults.
initPState = PState
  { indent       = 0   -- Indentation level
  , vis_chrs     = 0   -- Number of visible characters consumed.
  , str          = T.empty -- The string
  , columns_soft = 100  -- Soft limit on terminal width.
  , columns_hard = 120  -- Hard limit on terminal width.
  , curr_col     = 0   -- Column position in the current row.
  , curr_row     = 0   -- Number of newlines seen
  }

-- | Prettify a string by putting it on the end of the current string state
pLine :: T.Text -> Pretty
pLine s = do
  pStr s
  _pNewLine

-- | Pretty print a literal string by just printing the string.
pStr' :: String -> Pretty
pStr' = pStr . T.pack

-- | This currently assumes all input strings contain no newlines, and that this is
--   only called on relatively small strings because strings running over the end
--   of the hard column limit get dumped onto the next line __no matter what__.
--   T.Texts can run over the soft limit, but hitting the soft limit after a call
--   to 'pStr' forces a newline.
pStr :: T.Text -> Pretty
pStr s = do
  pstate <- get
  _doIf _pNewLine (T.length s + curr_col pstate > columns_hard pstate && curr_col pstate /= 0)
  pstate <- get
  _doIf _pIndent  (curr_col pstate == 0 && indent pstate > 0)
  pstate <- get
  put $ pstate
    { str = T.append (str pstate) s
    , curr_col = (curr_col pstate) + T.length s
    }
  pstate <- get
  _doIf _pNewLine (curr_col pstate > columns_soft pstate)

-- | Print a single character to the output.
pChr :: Char -> Pretty
pChr c = pStr $ T.singleton c

-- | Gets rid of if-then-else lines in the Pretty monad code:
_doIf fncn True  = fncn
_doIf fncn False = return ()

-- | Indent by the number of spaces specified in the state.
_pIndent :: Pretty
_pIndent = do
  pstate <- get
  put $ pstate
    { str      = str pstate `T.append` T.replicate (indent pstate) (T.singleton ' ')
    , curr_col = curr_col pstate + indent pstate
    , vis_chrs = vis_chrs pstate + indent pstate
    }

-- | Insert a newline
_pNewLine :: Pretty
_pNewLine = do
  pstate <- get
  put $ pstate
    { str = T.snoc (str pstate) '\n'
    , curr_col = 0
    , curr_row = curr_row pstate + 1
    }

-- | Run the pretty-printer, returning a 'T.Text'.
pshow :: (Prettify t) => t -> T.Text
pshow t = str $ execState (prettify t) initPState

-- | Run the pretty-printer, returning a 'String'.
pshow' :: (Prettify t) => t -> String
pshow' = T.unpack . pshow

-- | Run the pretty-printer with a specific indentation level.
pshowIndent :: (Prettify t) => Int -> t -> T.Text
pshowIndent i t = str $ execState (prettify t) $ initPState { indent = i }

-- | Plain-vanilla show of something in the 'Pretty' state monad.
rshow :: (Show t) => t -> Pretty
rshow t = do
  pstate <- get
  let s = show t
  put $ pstate
    { str      = str pstate `T.append` T.pack s
    , curr_row = curr_row pstate + (T.length . T.filter (== '\n')) (T.pack s)
    , curr_col = curr_col pstate -- TODO
    }

-- | Parenthesize something in 'Pretty'.
pParens fncn = do
  pChr '('
  fncn
  pChr ')'

-- | Increment the indentation level by modifying the pretty-printer state.
incrIndent :: Int -> Pretty
incrIndent n = do
  pstate <- get
  put $ pstate { indent = indent pstate + n }

-- | Like 'incrIndent' but set indentation level instead of incrementing.
setIndent :: Int -> Pretty
setIndent n = do
  pstate <- get
  put $ pstate { indent = n }

-- | Prettify the given value and compute the number of characters consumed as a
--   result.
pCount :: (Prettify v) => v -> PrettyM Int
pCount v = do
  i0 <- indent <$> get
  prettify v
  i1 <- indent <$> get
  return (i1 - i0)

-- | Pretty-print a list with one entry per line.
pListLines :: (Prettify v) => [v] -> Pretty
pListLines vs = do
  pStr $ T.pack "[ "
  col0 <- curr_col <$> get
  i0   <- indent   <$> get
  setIndent (col0 - 2)
  sepBy (pLine T.empty >> (pStr $ T.pack ", ")) (map prettify vs)
  pLine T.empty >> pChr ']'
  setIndent i0 -- Reset indentation back to what it was

instance (Prettify k, Prettify v) => Prettify (M.Map k v) where
  prettify m = do
    -- (5 == length of "Map: ") ==> TODO: indentation "discipline"
    pStr "Map: "; incrIndent 5
    prettify $ M.toList m -- TODO: prettier map
    incrIndent (-5)

instance (Prettify v) => Prettify (Maybe v) where
  prettify Nothing  = pStr "Nope"
  prettify (Just v) = pStr "Yep" >> pParens (prettify v)

-- | Prettify a list with possibly more than one entry per line.
prettifyList_ [] = pStr "[]"
prettifyList_ vs = do
  pChr '['
  sepBy (pStr ", ") (map prettify vs)
  pChr ']'

instance (Prettify v) => Prettify [v] where
  prettify = prettifyList 

-- TODO: template haskell-ify for larger tuples
instance (Prettify a, Prettify b) => Prettify (a,b) where
  prettify (a,b) = do
    pChr '('
    prettify a
    pChr ','
    prettify b
    pChr ')'

instance (Prettify a, Prettify b, Prettify c) => Prettify (a,b,c) where
  prettify (a,b,c) = do
    pChr '('
    prettify a
    pChr ','
    prettify b
    pChr ','
    prettify c
    pChr ')'

instance (Prettify a, Prettify b, Prettify c, Prettify d) => Prettify (a,b,c,d) where
  prettify (a,b,c,d) = do
    pChr '('
    prettify a
    pChr ','
    prettify b
    pChr ','
    prettify c
    pChr ','
    prettify d
    pChr ')'

-- | Pretty-print a list of values, separated by some other pretty-printer.
sepBy s [] = return ()
sepBy s (v:vs) = foldl (_sepBy s) v vs

-- | Reorder pretty-printer bind.
_sepBy s ma mb = ma >> s >> mb 

instance Prettify Char where
  prettify = pChr
  prettifyList = pStr . T.pack

instance Prettify () where prettify = rshow
instance Prettify Bool where prettify = rshow
instance Prettify Int where prettify = rshow

instance Prettify Double where prettify = rshow