zmidi-core-0.8.2: src/ZMidi/Core/Internal/SimpleFormat.hs
{-# LANGUAGE CPP #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : ZMidi.Core.Internal.SimpleFormat
-- Copyright : (c) Stephen Tetley 2010-2015
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : unstable
-- Portability : As per dependencies.
--
-- Simple line-oriented formatting combinators.
--
--------------------------------------------------------------------------------
module ZMidi.Core.Internal.SimpleFormat
(
ColumnSpecs(..)
, ColumnSpec(..)
, Table
, runTable
, execTable
, tellFree
, tellRow
, tellBlank
, tellBreak
, localColumns
, nextTrack
, arbTrack
, incrDelta
, WString
, width
, outputDoc
, (<+>)
, sep
, char
, text
, repeatChar
, padl
, padr
, hex2
, hex4
, int
, integral
) where
#ifndef MIN_VERSION_GLASGOW_HASKELL
import Control.Applicative
#endif
#ifndef MIN_VERSION_GLASGOW_HASKELL
import Data.Monoid
#endif
import Data.Word
import Numeric
-- | Strings are represented as Hughes lists
--
-- ShowS is a Hughes list representation specialized to Strings
--
type H a = [a] -> [a]
type HString = H Char
type HLines = H String
-- | Make a HString of spaces.
--
spaceH :: Int -> HString
spaceH n = showString $ replicate n ' '
-- | Materialize a Hughes list.
--
fromH :: H a -> [a]
fromH = ($ [])
-- | Empty Hughes list.
--
emptyH :: H a
emptyH = id
-- | Snoc an element to the right end.
--
snocH :: H a -> a -> H a
snocH f a = f . (a:)
--------------------------------------------------------------------------------
-- | Column formats for table printing.
--
data ColumnSpecs = ColumnSpecs { col_sep :: Char, col_fmts :: [ColumnSpec] }
deriving (Eq,Show)
-- | Print a column with left or right padding.
--
data ColumnSpec = PadL Int | PadR Int
deriving (Eq,Ord,Show)
-- | Internal state.
--
data St = St { get_tracknum :: !Int, get_acctime :: Integer }
-- | Initial state.
--
state_zero :: St
state_zero = St { get_tracknum = 0
, get_acctime = 0
}
-- | Monad for generating output as a table.
--
newtype Table a = Table {
getTable :: ColumnSpecs -> St -> HLines -> (St,HLines,a) }
instance Functor Table where
fmap f ma = Table $ \r s ac ->
let (s1,ac1,a) = getTable ma r s ac in (s1, ac1, f a)
instance Applicative Table where
pure a = Table $ \_ s ac -> (s,ac,a)
mf <*> ma = Table $ \r s ac ->
let (s1,ac1,f) = getTable mf r s ac
(s2,ac2,a) = getTable ma r s1 ac1
in (s2,ac2,f a)
instance Monad Table where
return = pure
ma >>= k = Table $ \r s ac ->
let (s1,ac1,a) = getTable ma r s ac in getTable (k a) r s1 ac1
-- | Run the Table monad, returning both output and answer.
--
runTable :: ColumnSpecs -> Table a -> ([String],a)
runTable hdrs ma =
let (_,hf,a) = getTable ma hdrs state_zero emptyH in (fromH hf,a)
-- | Exec the Table monad, returning just the output.
--
execTable :: ColumnSpecs -> Table a -> [String]
execTable hdrs = fst . runTable hdrs
-- | Tell a row with free formatting.
--
-- Row is actually a function : track_num * running_time -> WString
--
tellFree :: (Int -> Integer -> WString) -> Table ()
tellFree wf = Table $ \_ s ac ->
let next = fromH $ doch $ wf (get_tracknum s) (get_acctime s)
in (s, ac `snocH` next, ())
-- | Tell a row with column formatting.
--
-- Row is actually a function : track_num * running_time -> [WString]
--
tellRow :: (Int -> Integer -> [WString]) -> Table ()
tellRow wsf = Table $ \r s ac ->
let next = formatRow r $ wsf (get_tracknum s) (get_acctime s)
in (s, ac `snocH` next, ())
-- | Tell a blank line.
--
tellBlank :: Table ()
tellBlank = Table $ \_ s ac -> let next = ""
in (s, ac `snocH` next, ())
-- | Tell a breaking line (formatted as a dashed line).
--
tellBreak :: Table ()
tellBreak = Table $ \r s ac -> let next = formatBreak r
in (s, ac `snocH` next, ())
-- | Run the Table monad with a local ColumnSpecs, cf. the
-- @local@ function of the Reader monad class.
--
localColumns :: ColumnSpecs -> Table a -> Table a
localColumns r1 ma = Table $ \_ s ac -> getTable ma r1 s ac
-- | Proceed to the next track - reset running time.
--
nextTrack :: Table ()
nextTrack = Table $ \_ s ac -> (upd s, ac, ())
where
upd = (\s n -> s { get_tracknum = n+1, get_acctime = 0}) <*> get_tracknum
-- | Proceed to an arbitrary track - reset running time.
--
arbTrack :: Int -> Table ()
arbTrack n = Table $ \_ _ ac ->
(St { get_tracknum = n, get_acctime = 0}, ac, ())
-- | Increment runninf time.
--
incrDelta :: Integer -> Table ()
incrDelta dt = Table $ \_ s ac -> (upd s, ac, ())
where
upd = (\s n -> s { get_acctime = n + dt }) <*> get_acctime
-- | Helper for generating a line break
--
formatBreak :: ColumnSpecs -> String
formatBreak spec = replicate (lineLength spec) '-'
-- | Helper for generating a row.
--
formatRow :: ColumnSpecs -> [WString] -> String
formatRow (ColumnSpecs ch fmts) ws = fromH $ doch $ step fmts ws
where
fmt1 = PadL 9
-- if run out of formats use default...
step [] xs = step [fmt1] xs
step _ [] = mempty
step (c:_) [x] = format1 c x
step (c:cs) (x:xs) = let d1 = format1 c x; ds = step cs xs
in sep ch d1 ds
-- | Helper for generating a single column.
--
format1 :: ColumnSpec -> WString -> WString
format1 (PadL n) w = if n > width w then padl n w else w
format1 (PadR n) w = if n > width w then padr n w else w
-- | Calculate the line length.
--
lineLength :: ColumnSpecs -> Int
lineLength (ColumnSpecs _ fmts) = step 0 fmts
where
step w [] = w
step w [x] = w + size x
step w (x:xs) = step (w + size x + 1) xs
size (PadL i) = i
size (PadR i) = i
-- | Docs represent a single line - they should not contain
-- newlines.
--
data WString = WString {
-- | Width of the doc.
width :: !Int,
-- | Internal representation.
doch :: HString }
-- | Make a literal Doc from a String.
--
wstring :: String -> WString
wstring s = WString (length s) (showString s)
-- | Unwrap a Doc making a String.
--
outputDoc :: WString -> String
outputDoc = fromH . doch
-- | Concatenation is /directly next to/ i.e. no space.
--
instance Monoid WString where
mempty = WString 0 id
WString w1 f1 `mappend` WString w2 f2 = WString (w1+w2) (f1 . f2)
#if MIN_VERSION_base(4,11,0)
instance Semigroup WString where
(<>) = mappend
#endif
infixr 6 <+>
-- | Concatenate two WStrings with a space between them.
--
(<+>) :: WString -> WString -> WString
(<+>) = sep ' '
-- | Concatenate - with a single character separator.
--
sep :: Char -> WString -> WString -> WString
sep ch (WString w1 f1) (WString w2 f2) = WString (1+w1+w2) (f1 . (ch:) . f2)
-- | Make a WString from a Char.
--
char :: Char -> WString
char c = WString 1 (c:)
-- | Make a WString from a String.
--
text :: String -> WString
text = wstring
-- | Repeat the Char /n/ times to make a WString.
--
repeatChar :: Int -> Char -> WString
repeatChar n c = WString n (showString $ replicate n c)
-- | Pad the left with space.
--
padl :: Int -> WString -> WString
padl i d@(WString n f) | i > n = WString i (spaceH (i-n) . f)
| otherwise = d
-- | Pad the right with space.
--
padr :: Int -> WString -> WString
padr i d@(WString n f) | i > n = WString i (f . spaceH (i-n))
| otherwise = d
-- | Show as a two digit hex number.
--
hex2 :: Word8 -> WString
hex2 n | n < 0x10 = WString 2 (('0' :) . showHex n)
| otherwise = WString 2 (showHex n)
-- | Show as a four digit hex number.
--
hex4 :: Word16 -> WString
hex4 n | n < 0x10 = WString 4 (('0':) . ('0':) . ('0':) . showHex n)
| n < 0x100 = WString 4 (('0':) . ('0':) . showHex n)
| n < 0x1000 = WString 4 (('0':) . showHex n)
| otherwise = WString 4 (showHex n)
-- | Show an Int as a base 10 number.
--
int :: Int -> WString
int = wstring . show
-- | Show an Integral value as a base 10 number.
--
integral :: (Show a, Integral a) => a -> WString
integral = wstring . show