-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
-- | Convert realized 'S.Flat' output to text for the terminal.
module Solkattu.Format.Terminal (
    renderAll, printInstrument, printKonnakol, printBol
    , Config(..), defaultConfig
    , konnakolConfig, bolConfig
    , formatInstrument
#ifdef TESTING
    , module Solkattu.Format.Terminal
#endif
) where
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Styled as Styled

import qualified Solkattu.Format.Format as Format
import qualified Solkattu.Korvai as Korvai
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu
import qualified Solkattu.Tags as Tags
import qualified Solkattu.Tala as Tala
import qualified Solkattu.Talas as Talas

import           Global


type Error = Text

data Config = Config {
    -- | Show the ruler on multiples of this line as a reminder.  The ruler is
    -- always shown if it changes.  It should be a multiple of 2 to avoid
    -- getting the second half of a talam in case it's split in half.
    Config -> Int
_rulerEach :: !Int
    , Config -> Int
_terminalWidth :: !Int
    -- | Normally 'format' tries to figure out a with for each stroke according
    -- to what will fit on the screen.  But it assumes notation is always at
    -- most one character per time unit.  This hardcodes the width for e.g.
    -- konnakol, where a sollu like `thom` can be 4 characters wide.
    , Config -> Maybe Int
_overrideStrokeWidth :: !(Maybe Int)
    , Config -> Abstraction
_abstraction :: !Format.Abstraction
    } deriving (Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config
    { _rulerEach :: Int
_rulerEach = Int
4
    , _terminalWidth :: Int
_terminalWidth = Int
78
    , _overrideStrokeWidth :: Maybe Int
_overrideStrokeWidth = forall a. Maybe a
Nothing
    , _abstraction :: Abstraction
_abstraction = Abstraction
Format.defaultAbstraction
    }

konnakolConfig :: Config
konnakolConfig :: Config
konnakolConfig = Config
defaultConfig
    { _terminalWidth :: Int
_terminalWidth = Int
100
    , _overrideStrokeWidth :: Maybe Int
_overrideStrokeWidth = forall a. a -> Maybe a
Just Int
3
    }

bolConfig :: Config
bolConfig :: Config
bolConfig = Config
defaultConfig
    { _terminalWidth :: Int
_terminalWidth = Int
100
    -- 3 means dha and taa will fit, but it leads to excessively wide display.
    -- In practice dha often has a rest afterwards anyway.
    , _overrideStrokeWidth :: Maybe Int
_overrideStrokeWidth = forall a. a -> Maybe a
Just Int
2
    }

-- * write

-- | Render all instrument realizations.
renderAll :: Format.Abstraction -> Korvai.Score -> [Text]
renderAll :: Abstraction -> Score -> [Text]
renderAll Abstraction
abstraction Score
score = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GInstrument -> [Text]
write1 forall a b. (a -> b) -> a -> b
$ Score -> [GInstrument]
Format.scoreInstruments Score
score
    where
    write1 :: GInstrument -> [Text]
write1 (Korvai.GInstrument Instrument stroke
inst) =
        forall stroke. Instrument stroke -> Text
Korvai.instrumentName Instrument stroke
inst forall a. Semigroup a => a -> a -> a
<> Text
":"
        forall a. a -> [a] -> [a]
: forall a b. (a, b) -> a
fst (forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Score
-> ([Text], Bool)
formatScore (Config
config { _abstraction :: Abstraction
_abstraction = Abstraction
abstraction }) Instrument stroke
inst forall a. a -> Maybe a
Just
            Score
score)
        where
        config :: Config
config = case Instrument stroke
inst of
            Instrument stroke
Korvai.IKonnakol -> Config
konnakolConfig
            Instrument stroke
Korvai.IBol -> Config
bolConfig
            Instrument stroke
_ -> Config
defaultConfig

-- * format

printInstrument :: (Solkattu.Notation stroke, Ord stroke)
    => Korvai.Instrument stroke -> Format.Abstraction -> Korvai.Korvai
    -> IO ()
printInstrument :: forall stroke.
(Notation stroke, Ord stroke) =>
Instrument stroke -> Abstraction -> Korvai -> IO ()
printInstrument Instrument stroke
instrument Abstraction
abstraction =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Korvai
-> ([Text], Bool)
formatInstrument (Config
defaultConfig { _abstraction :: Abstraction
_abstraction = Abstraction
abstraction })
        Instrument stroke
instrument forall a. a -> Maybe a
Just

printKonnakol :: Config -> Korvai.Korvai -> IO ()
printKonnakol :: Config -> Korvai -> IO ()
printKonnakol Config
config =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Korvai
-> ([Text], Bool)
formatInstrument Config
config Instrument Sollu
Korvai.IKonnakol forall a. a -> Maybe a
Just

printBol :: Config -> Korvai.Korvai -> IO ()
printBol :: Config -> Korvai -> IO ()
printBol Config
config =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Korvai
-> ([Text], Bool)
formatInstrument Config
config Instrument Bol
Korvai.IBol forall a. a -> Maybe a
Just

formatScore
    :: (Solkattu.Notation stroke1, Solkattu.Notation stroke2, Ord stroke1)
    => Config
    -> Korvai.Instrument stroke1
    -> (Realize.Stroke stroke1 -> Maybe (Realize.Stroke stroke2))
    -> Korvai.Score -> ([Text], Bool)
    -- ^ (lines, hadError)
formatScore :: forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Score
-> ([Text], Bool)
formatScore Config
config Instrument stroke1
instrument Stroke stroke1 -> Maybe (Stroke stroke2)
postproc = \case
    Korvai.Single Korvai
korvai -> Korvai -> ([Text], Bool)
formatK Korvai
korvai
    Korvai.Tani Metadata
_ [Part Korvai]
parts -> (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
lines, forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
errors)
        where ([[Text]]
lines, [Bool]
errors) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Part Korvai -> ([Text], Bool)
format [Part Korvai]
parts
    where
    format :: Part Korvai -> ([Text], Bool)
format (Korvai.Comment Text
cmt) = ([Text
cmt], Bool
False)
    format (Korvai.K Korvai
korvai) = Korvai -> ([Text], Bool)
formatK Korvai
korvai
    formatK :: Korvai -> ([Text], Bool)
formatK = forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Korvai
-> ([Text], Bool)
formatInstrument Config
config Instrument stroke1
instrument Stroke stroke1 -> Maybe (Stroke stroke2)
postproc

formatInstrument
    :: (Solkattu.Notation stroke1, Solkattu.Notation stroke2, Ord stroke1)
    => Config
    -> Korvai.Instrument stroke1
    -> (Realize.Stroke stroke1 -> Maybe (Realize.Stroke stroke2))
    -- ^ postproc used to split wadon/lanang
    -> Korvai.Korvai
    -> ([Text], Bool) -- ^ (lines, hadError)
formatInstrument :: forall stroke1 stroke2.
(Notation stroke1, Notation stroke2, Ord stroke1) =>
Config
-> Instrument stroke1
-> (Stroke stroke1 -> Maybe (Stroke stroke2))
-> Korvai
-> ([Text], Bool)
formatInstrument Config
config Instrument stroke1
instrument Stroke stroke1 -> Maybe (Stroke stroke2)
postproc Korvai
korvai =
    forall stroke.
Notation stroke =>
Config
-> Tala
-> [(Tags, Either Text ([Flat stroke], [Warning]))]
-> ([Text], Bool)
formatResults Config
config (Korvai -> Tala
Korvai.korvaiTala Korvai
korvai) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (Korvai -> [Tags]
korvaiTags Korvai
korvai) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b g.
(Stroke a -> Maybe (Stroke b))
-> [Flat g (Note a)] -> [Flat g (Note b)]
Korvai.mapStrokeRest Stroke stroke1 -> Maybe (Stroke stroke2)
postproc))) forall a b. (a -> b) -> a -> b
$
        forall stroke warnings.
[Either Text ([Flat stroke], warnings)]
-> [Either Text ([Flat stroke], warnings)]
Format.convertGroups forall a b. (a -> b) -> a -> b
$
        forall stroke.
(Notation stroke, Ord stroke) =>
Instrument stroke -> Korvai -> [Either Text (Realized stroke)]
Korvai.realize Instrument stroke1
instrument Korvai
korvai

korvaiTags :: Korvai.Korvai -> [Tags.Tags]
korvaiTags :: Korvai -> [Tags]
korvaiTags = forall a b. (a -> b) -> [a] -> [b]
map forall a. Section a -> Tags
Korvai.sectionTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Korvai -> [Section ()]
Korvai.genericSections

formatResults :: Solkattu.Notation stroke => Config -> Talas.Tala
    -> [ ( Tags.Tags
         , Either Error ([Format.Flat stroke], [Realize.Warning])
         )
       ]
    -> ([Text], Bool)
formatResults :: forall stroke.
Notation stroke =>
Config
-> Tala
-> [(Tags, Either Text ([Flat stroke], [Warning]))]
-> ([Text], Bool)
formatResults Config
config Tala
tala [(Tags, Either Text ([Flat stroke], [Warning]))]
results =
    ( forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL PrevRuler
-> (Integer, (Tags, Either Text ([Flat stroke], [Warning])))
-> (PrevRuler, [Text])
show1 (forall a. Maybe a
Nothing, Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] forall a b. (a -> b) -> a -> b
$ [(Tags, Either Text ([Flat stroke], [Warning]))]
results
    , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b. Either a b -> Bool
Either.isLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Tags, Either Text ([Flat stroke], [Warning]))]
results
    )
    where
    show1 :: PrevRuler
-> (Integer, (Tags, Either Text ([Flat stroke], [Warning])))
-> (PrevRuler, [Text])
show1 PrevRuler
_ (Integer
_section, (Tags
_, Left Text
err)) =
        ((forall a. Maybe a
Nothing, Int
0), [Int -> Text -> Text
Text.replicate Int
leader Text
" " forall a. Semigroup a => a -> a -> a
<> Text
"ERROR:\n" forall a. Semigroup a => a -> a -> a
<> Text
err])
    show1 PrevRuler
prevRuler (Integer
section, (Tags
tags, Right ([Flat stroke]
notes, [Warning]
warnings))) =
        ( PrevRuler
nextRuler
        -- Use an empty section with commentS to describe what to play.
        , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Flat stroke]
notes
            then (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ Bool -> Integer -> Text
sectionNumber Bool
False Integer
section
                forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"empty" [Text] -> Text
Text.unwords
                    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
Tags.comment (Tags -> Map Text [Text]
Tags.untags Tags
tags))
            else Integer -> Tags -> [(LineType, Styled)] -> [Text]
sectionFmt Integer
section Tags
tags [(LineType, Styled)]
lines
                forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Int -> Warning -> Text
showWarning Int
strokeWidth) [Warning]
warnings
        )
        where
        (Int
strokeWidth, (PrevRuler
nextRuler, [(LineType, Styled)]
lines)) = forall stroke.
Notation stroke =>
Config
-> PrevRuler
-> Tala
-> [Flat stroke]
-> (Int, (PrevRuler, [(LineType, Styled)]))
format Config
config PrevRuler
prevRuler Tala
tala [Flat stroke]
notes
    showWarning :: Int -> Warning -> Text
showWarning Int
_ (Realize.Warning Maybe Int
Nothing Text
msg) = Text
msg
    showWarning Int
strokeWidth (Realize.Warning (Just Int
i) Text
msg) =
        Int -> Text -> Text
Text.replicate (Int
leader forall a. Num a => a -> a -> a
+ Int
strokeWidth forall a. Num a => a -> a -> a
* Int
i) Text
" " forall a. Semigroup a => a -> a -> a
<> Text
"^ " forall a. Semigroup a => a -> a -> a
<> Text
msg
        -- TODO the ^ only lines up if there is only one line.  Otherwise
        -- I have to divMod i by strokes per line, and use that to insert
        -- in the formatted output
    -- If I want to normalize speed across all sections, then this is the place
    -- to get it.  I originally tried this, but from looking at the results I
    -- think I like when the notation can get more compact.
    -- toSpeed = maximum $ 0 : map S.maxSpeed (mapMaybe notesOf results)
    -- notesOf (_, Right (notes, _)) = Just notes
    -- notesOf _ = Nothing
    sectionFmt :: Integer -> Tags -> [(LineType, Styled)] -> [Text]
sectionFmt Integer
section Tags
tags =
        (if Text -> Bool
Text.null Text
tagsText then forall a. a -> a
id
            else forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall a. Semigroup a => a -> a -> a
<> Text
"   " forall a. Semigroup a => a -> a -> a
<> Text
tagsText))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (Tags -> Integer -> Bool -> (LineType, Text) -> (Bool, Text)
addHeader Tags
tags Integer
section) Bool
False
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Styled -> Text
Styled.toText))
        where
        tagsText :: Text
tagsText = Tags -> Text
Format.showTags Tags
tags
    addHeader :: Tags -> Integer -> Bool -> (LineType, Text) -> (Bool, Text)
addHeader Tags
tags Integer
section Bool
showedNumber (LineType
AvartanamStart, Text
line) =
        ( Bool
True
        , (if Bool -> Bool
not Bool
showedNumber then Bool -> Integer -> Text
sectionNumber (Tags -> Bool
isEnding Tags
tags) Integer
section
            else Int -> Char -> Text -> Text
Text.justifyRight Int
leader Char
' ' Text
"> ") forall a. Semigroup a => a -> a -> a
<> Text
line
        )
    addHeader Tags
_ Integer
_ Bool
showedNumber (LineType
_, Text
line) =
        (Bool
showedNumber, Int -> Text -> Text
Text.replicate Int
leader Text
" " forall a. Semigroup a => a -> a -> a
<> Text
line)
    sectionNumber :: Bool -> Integer -> Text
sectionNumber Bool
isEnding Integer
section = Styled -> Text
Styled.toText forall a b. (a -> b) -> a -> b
$
        forall a. ToStyled a => Color -> a -> Styled
Styled.bg (Color -> Color
Styled.bright Color
color) forall a b. (a -> b) -> a -> b
$
        Int -> Char -> Text -> Text
Text.justifyLeft Int
leader Char
' ' (forall a. Show a => a -> Text
showt Integer
section forall a. Semigroup a => a -> a -> a
<> Text
":")
        where
        -- Highlight endings specially, seems to be a useful landmark.
        color :: Color
color = if Bool
isEnding then Color
Styled.cyan else Color
Styled.yellow
    leader :: Int
leader = Int
4
    isEnding :: Tags -> Bool
isEnding = (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just [Text
Tags.ending]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
Tags.type_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tags -> Map Text [Text]
Tags.untags


-- * implementation

-- | Keep state about the last ruler across calls to 'format', so I can
-- suppress unneeded ones.  (prevRuler, lineNumber)
type PrevRuler = (Maybe Format.Ruler, Int)

type Line = [(S.State, Symbol)]

data LineType = Ruler | AvartanamStart | AvartanamContinue
    deriving (LineType -> LineType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineType -> LineType -> Bool
$c/= :: LineType -> LineType -> Bool
== :: LineType -> LineType -> Bool
$c== :: LineType -> LineType -> Bool
Eq, Int -> LineType -> ShowS
[LineType] -> ShowS
LineType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineType] -> ShowS
$cshowList :: [LineType] -> ShowS
show :: LineType -> String
$cshow :: LineType -> String
showsPrec :: Int -> LineType -> ShowS
$cshowsPrec :: Int -> LineType -> ShowS
Show)

-- | Format the notes according to the tala.
--
-- The line breaking for rulers is a bit weird in that if the line is broken,
-- I only emit the first part of the ruler.  Otherwise I'd have to have
-- a multiple line ruler too, which might be too much clutter.  I'll have to
-- see how it works out in practice.
format :: Solkattu.Notation stroke => Config -> PrevRuler -> Talas.Tala
    -> [Format.Flat stroke] -> (Int, (PrevRuler, [(LineType, Styled.Styled)]))
format :: forall stroke.
Notation stroke =>
Config
-> PrevRuler
-> Tala
-> [Flat stroke]
-> (Int, (PrevRuler, [(LineType, Styled)]))
format Config
config PrevRuler
prevRuler Tala
tala [Flat stroke]
notes =
    (Int
strokeWidth,) forall a b. (a -> b) -> a -> b
$
    forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(Maybe Ruler, [(State, Symbol)])] -> [(LineType, Styled)]
formatAvartanam) forall a b. (a -> b) -> a -> b
$
    forall sym.
Int
-> PrevRuler
-> Tala
-> Int
-> [[Line sym]]
-> (PrevRuler, [[(Maybe Ruler, Line sym)]])
Format.pairWithRuler (Config -> Int
_rulerEach Config
config) PrevRuler
prevRuler Tala
tala Int
strokeWidth
        [[[(State, Symbol)]]]
avartanamLines
    where
    formatAvartanam :: [(Maybe Ruler, [(State, Symbol)])] -> [(LineType, Styled)]
formatAvartanam = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Ruler, [(State, Symbol)]) -> [(LineType, Styled)]
formatRulerLine
    formatRulerLine :: (Maybe Ruler, [(State, Symbol)]) -> [(LineType, Styled)]
formatRulerLine (Maybe Ruler
mbRuler, [(State, Symbol)]
line) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case Maybe Ruler
mbRuler of
            Maybe Ruler
Nothing -> []
            Just Ruler
ruler -> [(LineType
Ruler, Int -> Ruler -> Styled
formatRuler Int
strokeWidth Ruler
ruler)]
        , [(if Bool
isFirst then LineType
AvartanamStart else LineType
AvartanamContinue,
            [Symbol] -> Styled
formatLine (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(State, Symbol)]
line))]
        ]
        where
        isFirst :: Bool
isFirst = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Eq a => a -> a -> Bool
==Duration
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Duration
S.stateMatraPosition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
            (forall a. [a] -> Maybe a
Lists.head [(State, Symbol)]
line)

    avartanamLines :: [[Line]] -- [avartanam] [[line]] [[[sym]]]
    ([[[(State, Symbol)]]]
avartanamLines, Int
strokeWidth) = case Config -> Maybe Int
_overrideStrokeWidth Config
config of
        Just Int
n -> (Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
fmt Int
n Int
width Tala
tala [Flat stroke]
notes, Int
n)
        Maybe Int
Nothing -> case Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
fmt Int
1 Int
width Tala
tala [Flat stroke]
notes of
            [[(State, Symbol)]
line] : [[[(State, Symbol)]]]
_ | [(State, Symbol)] -> Int
lineWidth [(State, Symbol)]
line forall a. Ord a => a -> a -> Bool
<= Int
width forall a. Integral a => a -> a -> a
`div` Int
2 ->
                (Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
fmt Int
2 Int
width Tala
tala [Flat stroke]
notes, Int
2)
            [[[(State, Symbol)]]]
result -> ([[[(State, Symbol)]]]
result, Int
1)
        where fmt :: Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
fmt = forall stroke.
Notation stroke =>
Abstraction
-> Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
formatLines (Config -> Abstraction
_abstraction Config
config)
    formatLine :: [Symbol] -> Styled.Styled
    formatLine :: [Symbol] -> Styled
formatLine = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Styled
formatSymbol
    width :: Int
width = Config -> Int
_terminalWidth Config
config

lineWidth :: Line -> Int
lineWidth :: [(State, Symbol)] -> Int
lineWidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Int
symLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

formatRuler :: Int -> Format.Ruler -> Styled.Styled
formatRuler :: Int -> Ruler -> Styled
formatRuler Int
strokeWidth =
    forall a. ToStyled a => Color -> a -> Styled
Styled.bg (Color -> Color
Styled.bright Color
Styled.white)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Int -> (Text, Int) -> (Int, Text)
render Int
0
    where
    render :: Int -> (Text, Int) -> (Int, Text)
render Int
debt (Text
mark, Int
spaces) =
        ( forall a. Ord a => a -> a -> a
max Int
0 (-Int
append) -- debt is how many spaces I'm behind
        , Text
mark forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
append Text
" "
        )
        where
        append :: Int
append = Int
spaces forall a. Num a => a -> a -> a
* Int
strokeWidth forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
mark forall a. Num a => a -> a -> a
- Int
debt

-- | Replace two rests starting on an even note, with a Realize.doubleRest.
-- This is an elementary form of rhythmic spelling.
--
-- But if strokeWidth=1, then replace replace odd _ with ' ', to avoid clutter.
spellRests :: Int -> [Symbol] -> [Symbol]
spellRests :: Int -> [Symbol] -> [Symbol]
spellRests Int
strokeWidth
    | Int
strokeWidth forall a. Eq a => a -> a -> Bool
== Int
1 = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Integral a => (a, Symbol) -> Symbol
thin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..]
    | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map forall {a}.
Integral a =>
(a, (Maybe Symbol, Symbol, Maybe Symbol)) -> Symbol
set forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(Maybe a, a, Maybe a)]
Lists.zipNeighbors
    where
    thin :: (a, Symbol) -> Symbol
thin (a
col, Symbol
sym)
        | Symbol -> Bool
isRest Symbol
sym Bool -> Bool -> Bool
&& forall a. Integral a => a -> Bool
odd a
col = Symbol
sym { _text :: Text
_text = Text
" " }
        | Bool
otherwise = Symbol
sym
    set :: (a, (Maybe Symbol, Symbol, Maybe Symbol)) -> Symbol
set (a
col, (Maybe Symbol
prev, Symbol
sym, Maybe Symbol
next))
        | Bool -> Bool
not (Symbol -> Bool
isRest Symbol
sym) = Symbol
sym
        | forall a. Integral a => a -> Bool
even a
col Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Symbol -> Bool
isRest Maybe Symbol
next = Symbol
sym
            { _text :: Text
_text = Int -> Char -> Text -> Text
Realize.justifyLeft (Symbol -> Int
symLength Symbol
sym) Char
' ' Text
double }
        | forall a. Integral a => a -> Bool
odd a
col Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Symbol -> Bool
isRest Maybe Symbol
prev = Symbol
sym
            { _text :: Text
_text = Int -> Text -> Text
Text.replicate (Symbol -> Int
symLength Symbol
sym) Text
" " }
        | Bool
otherwise = Symbol
sym
    double :: Text
double = Char -> Text
Text.singleton Char
Realize.doubleRest

-- This should be (== Space Rest), but I have to 'makeSymbols' first to break
-- lines.
isRest :: Symbol -> Bool
isRest :: Symbol -> Bool
isRest = (forall a. Eq a => a -> a -> Bool
==Text
"_") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
_text

-- | Break into [avartanam], where avartanam = [line].
formatLines :: Solkattu.Notation stroke => Format.Abstraction -> Int
    -> Int -> Talas.Tala -> [Format.Flat stroke] -> [[[(S.State, Symbol)]]]
formatLines :: forall stroke.
Notation stroke =>
Abstraction
-> Int -> Int -> Tala -> [Flat stroke] -> [[[(State, Symbol)]]]
formatLines Abstraction
abstraction Int
strokeWidth Int
width Tala
tala [Flat stroke]
notes =
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a b x. ([a] -> [b]) -> [(x, a)] -> [(x, b)]
Format.mapSnd (Int -> [Symbol] -> [Symbol]
spellRests Int
strokeWidth)))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall note a.
(note -> Bool)
-> (note -> Bool) -> [[[(a, note)]]] -> [[[(a, note)]]]
Format.formatFinalAvartanam Symbol -> Bool
isRest Symbol -> Bool
_isOverlappingSymbol
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> [(State, Symbol)] -> [[(State, Symbol)]]
breakLine Int
width)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(State, a)] -> [[(State, a)]]
Format.breakAvartanams
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [(a, Symbol)] -> [(a, Symbol)]
overlapSymbols Int
strokeWidth
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall stroke.
Notation stroke =>
Int
-> Tala -> Set Int -> NormalizedFlat stroke -> [(State, Symbol)]
makeSymbols Int
strokeWidth Tala
tala Set Int
angas)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke.
Abstraction -> [NormalizedFlat stroke] -> [NormalizedFlat stroke]
Format.makeGroupsAbstract Abstraction
abstraction
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stroke.
Int -> Int -> [Flat stroke] -> [NormalizedFlat stroke]
Format.normalizeSpeed Int
toSpeed (Tala -> Int
Talas.aksharas Tala
tala)
        forall a b. (a -> b) -> a -> b
$ [Flat stroke]
notes
    where
    angas :: Set Int
angas = Tala -> Set Int
Talas.angaSet Tala
tala
    toSpeed :: Int
toSpeed = forall g a. [Flat g a] -> Int
S.maxSpeed [Flat stroke]
notes

-- | Long names will overlap following _isSustain ones.
overlapSymbols :: Int -> [(a, Symbol)] -> [(a, Symbol)]
overlapSymbols :: forall a. Int -> [(a, Symbol)] -> [(a, Symbol)]
overlapSymbols Int
strokeWidth = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a b x.
(state -> a -> (state, b))
-> state -> [(x, a)] -> (state, [(x, b)])
mapAccumLSnd (Text, Maybe Symbol) -> Symbol -> ((Text, Maybe Symbol), Symbol)
combine (Text
"", forall a. Maybe a
Nothing)
    where
    combine :: (Text, Maybe Symbol) -> Symbol -> ((Text, Maybe Symbol), Symbol)
combine (Text
overlap, Maybe Symbol
overlapSym) Symbol
sym
        | Symbol -> Bool
_isSustain Symbol
sym = if Text -> Bool
Text.null Text
overlap
            then ((Text
"", forall a. Maybe a
Nothing), Symbol
sym)
            else let (Text
pre, Text
post) = Int -> Text -> (Text, Text)
textSplitAt Int
strokeWidth Text
overlap
                in ((Text
post, Maybe Symbol
overlapSym), Text -> Maybe Symbol -> Symbol -> Symbol
replace Text
pre Maybe Symbol
overlapSym Symbol
sym)
        | Bool
otherwise =
            let (Text
pre, Text
post) = Int -> Text -> (Text, Text)
textSplitAt Int
strokeWidth (Symbol -> Text
_text Symbol
sym)
            in ((Text
post, forall a. a -> Maybe a
Just Symbol
sym), Symbol
sym { _text :: Text
_text = Text
pre })
    replace :: Text -> Maybe Symbol -> Symbol -> Symbol
replace Text
prefix Maybe Symbol
mbOverlapSym Symbol
sym = case Maybe Symbol
mbOverlapSym of
        Maybe Symbol
Nothing -> Symbol
sym { _text :: Text
_text = Text
newText }
        Just Symbol
overlapSym -> Symbol
sym
            { _text :: Text
_text = Text
newText
            , _highlight :: Maybe (Highlight, Color)
_highlight = Symbol -> Maybe (Highlight, Color)
_highlight Symbol
overlapSym
            , _emphasize :: Bool
_emphasize = Symbol -> Bool
_emphasize Symbol
overlapSym
            , _isOverlappingSymbol :: Bool
_isOverlappingSymbol = Bool
True
            }
        where
        newText :: Text
newText = Text
prefix
            forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Int -> Text -> (Text, Text)
textSplitAt (Text -> Int
Realize.textLength Text
prefix) (Symbol -> Text
_text Symbol
sym))

makeSymbols :: Solkattu.Notation stroke => Int -> Talas.Tala -> Set Tala.Akshara
    -> Format.NormalizedFlat stroke -> [(S.State, Symbol)]
makeSymbols :: forall stroke.
Notation stroke =>
Int
-> Tala -> Set Int -> NormalizedFlat stroke -> [(State, Symbol)]
makeSymbols Int
strokeWidth Tala
tala Set Int
angas = Flat Meta (State, Stroke (Note stroke)) -> [(State, Symbol)]
go
    where
    go :: Flat Meta (State, Stroke (Note stroke)) -> [(State, Symbol)]
go (S.FNote Tempo
_ (State
state, Stroke (Note stroke)
note)) =
        (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ (State
state,) forall a b. (a -> b) -> a -> b
$ State -> (Bool, Style, Text) -> Symbol
makeSymbol State
state forall a b. (a -> b) -> a -> b
$ case Stroke (Note stroke)
note of
            S.Attack Note stroke
a ->
                ( Bool
False
                , Style
style
                , Int -> Char -> Text -> Text
Realize.justifyLeft Int
strokeWidth (forall a. Notation a => a -> Char
Solkattu.extension Note stroke
a)
                    Text
notation
                )
                where (Style
style, Text
notation) = forall a. Notation a => a -> (Style, Text)
Solkattu.notation Note stroke
a
            S.Sustain Note stroke
a ->
                ( Bool
True
                , forall a. Monoid a => a
mempty
                , Int -> Text -> Text
Text.replicate Int
strokeWidth
                    (Char -> Text
Text.singleton (forall a. Notation a => a -> Char
Solkattu.extension Note stroke
a))
                )
            Stroke (Note stroke)
S.Rest -> (Bool
True, forall a. Monoid a => a
mempty, Int -> Char -> Text -> Text
Realize.justifyLeft Int
strokeWidth Char
' ' Text
"_")
    go (S.FGroup Tempo
_ Meta
group [Flat Meta (State, Stroke (Note stroke))]
children) = [(State, Symbol)] -> [(State, Symbol)]
modify (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Flat Meta (State, Stroke (Note stroke)) -> [(State, Symbol)]
go [Flat Meta (State, Stroke (Note stroke))]
children)
        where
        modify :: [(State, Symbol)] -> [(State, Symbol)]
modify = case Meta -> GroupType
Solkattu._type Meta
group of
            GroupType
Solkattu.GGroup -> forall {a}. [(a, Symbol)] -> [(a, Symbol)]
groupc
            GroupType
Solkattu.GReductionT -> forall {a}. [(a, Symbol)] -> [(a, Symbol)]
groupc
            GroupType
Solkattu.GFiller -> forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> [p a Symbol] -> [p a Symbol]
setHighlights2 (Float -> Color
gray Float
0.85)
            GroupType
Solkattu.GPattern -> forall {a}. [(a, Symbol)] -> [(a, Symbol)]
patternc
            GroupType
Solkattu.GExplicitPattern -> forall {a}. [(a, Symbol)] -> [(a, Symbol)]
patternc
            GroupType
Solkattu.GSarva -> forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> [p a Symbol] -> [p a Symbol]
setHighlights2 (Float -> Float -> Float -> Color
Styled.rgb Float
0.5 Float
0.65 Float
0.5)
            -- This shouldn't be here, so make it red.
            Solkattu.GCheckDuration {} -> forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> [p a Symbol] -> [p a Symbol]
setHighlights2 (Float -> Float -> Float -> Color
Styled.rgb Float
0.75 Float
0 Float
0)
    groupc :: [(a, Symbol)] -> [(a, Symbol)]
groupc = forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> Color -> [p a Symbol] -> [p a Symbol]
setHighlights (Float -> Float -> Float -> Color
Styled.rgb Float
0.5 Float
0.75 Float
0.5) (Float -> Color
gray Float
0.75)
    patternc :: [(a, Symbol)] -> [(a, Symbol)]
patternc = forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> Color -> [p a Symbol] -> [p a Symbol]
setHighlights
        (Float -> Float -> Float -> Color
Styled.rgb Float
0.55 Float
0.55 Float
0.7) (Float -> Float -> Float -> Color
Styled.rgb Float
0.65 Float
0.65 Float
0.8)
    gray :: Float -> Color
gray Float
n = Float -> Float -> Float -> Color
Styled.rgb Float
n Float
n Float
n
    setHighlights2 :: Color -> [p a Symbol] -> [p a Symbol]
setHighlights2 Color
color = forall {p :: * -> * -> *} {a}.
Bifunctor p =>
Color -> Color -> [p a Symbol] -> [p a Symbol]
setHighlights Color
color Color
color
    setHighlights :: Color -> Color -> [p a Symbol] -> [p a Symbol]
setHighlights Color
startColor Color
color =
        forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Highlight -> Color -> Symbol -> Symbol
set Highlight
Format.EndHighlight Color
color))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
Lists.mapHeadTail
            (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Highlight -> Color -> Symbol -> Symbol
set Highlight
Format.StartHighlight Color
startColor))
            (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Highlight -> Color -> Symbol -> Symbol
set Highlight
Format.Highlight Color
color))
        where
        set :: Highlight -> Color -> Symbol -> Symbol
set Highlight
h Color
color Symbol
sym = case Symbol -> Maybe (Highlight, Color)
_highlight Symbol
sym of
            Maybe (Highlight, Color)
Nothing -> Symbol
sym { _highlight :: Maybe (Highlight, Color)
_highlight = forall a. a -> Maybe a
Just (Highlight
h, Color
color) }
            -- Don't set highlight if it's already set.  This means the
            -- innermost group's highlight will show, which seems to be most
            -- useful in practice.
            Just (Highlight, Color)
_ -> Symbol
sym
    makeSymbol :: State -> (Bool, Style, Text) -> Symbol
makeSymbol State
state (Bool
isSustain, Style
style, Text
text) = Symbol
        { _text :: Text
_text = Text
text
        , _style :: Style
_style = Style
style
        , _isSustain :: Bool
_isSustain = Bool
isSustain
        , _emphasize :: Bool
_emphasize = Tala -> Set Int -> State -> Bool
shouldEmphasize Tala
tala Set Int
angas State
state
        , _highlight :: Maybe (Highlight, Color)
_highlight = forall a. Maybe a
Nothing
        , _isOverlappingSymbol :: Bool
_isOverlappingSymbol = Bool
False
        }

-- | Chapu talams are generally fast, so only emphasize the angas.  Other talas
-- are slower, and without such a strong beat, so emphasize every akshara.
shouldEmphasize :: Talas.Tala -> Set Tala.Akshara -> S.State -> Bool
shouldEmphasize :: Tala -> Set Int -> State -> Bool
shouldEmphasize Tala
tala Set Int
angas State
state
    | Bool
isChapu = Set Int -> State -> Bool
Format.onAnga Set Int
angas State
state
    | Bool
otherwise = State -> Bool
Format.onAkshara State
state
    where
    isChapu :: Bool
isChapu = case Tala
tala of
        Talas.Carnatic Tala
tala -> case Tala -> [Anga]
Tala._angas Tala
tala of
            Tala.Wave Int
_ : [Anga]
_ -> Bool
True
            Tala.Clap Int
_ : [Anga]
_ -> Bool
True
            [Anga]
_ -> Bool
False
        Talas.Hindustani Tal
_ -> Bool
False -- TODO there are fast tals also

-- | If the text goes over the width, break at the middle akshara, or the
-- last one before the width if there isn't a middle.
breakLine :: Int -> [(S.State, Symbol)] -> [[(S.State, Symbol)]]
breakLine :: Int -> [(State, Symbol)] -> [[(State, Symbol)]]
breakLine Int
maxWidth [(State, Symbol)]
notes
    | Int
width forall a. Ord a => a -> a -> Bool
<= Int
maxWidth = [[(State, Symbol)]
notes]
    | forall a. Integral a => a -> Bool
even Int
aksharas = forall {b}. Int -> [(State, b)] -> [[(State, b)]]
breakAt (Int
aksharas forall a. Integral a => a -> a -> a
`div` Int
2) [(State, Symbol)]
notes
    | Bool
otherwise = Int -> [(State, Symbol)] -> [[(State, Symbol)]]
breakBefore Int
maxWidth [(State, Symbol)]
notes
    where
    width :: Int
width = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Int
symLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(State, Symbol)]
notes
    aksharas :: Int
aksharas = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count (State -> Bool
Format.onAkshara forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(State, Symbol)]
notes
    breakAt :: Int -> [(State, b)] -> [[(State, b)]]
breakAt Int
akshara = forall {a}. (a, a) -> [a]
pairToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Eq a => a -> a -> Bool
==Int
akshara) forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Int
S.stateAkshara forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    pairToList :: (a, a) -> [a]
pairToList (a
a, a
b) = [a
a, a
b]

-- | Yet another word-breaking algorithm.  I must have 3 or 4 of these by now.
breakBefore :: Int -> [(S.State, Symbol)] -> [[(S.State, Symbol)]]
breakBefore :: Int -> [(State, Symbol)] -> [[(State, Symbol)]]
breakBefore Int
maxWidth =
    [[(State, Symbol)]] -> [[(State, Symbol)]]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore (State -> Bool
Format.onAkshara forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    where
    go :: [[(State, Symbol)]] -> [[(State, Symbol)]]
go [[(State, Symbol)]]
aksharas =
        case forall key a. (key -> Bool) -> [(key, a)] -> ([a], [a])
breakFst (forall a. Ord a => a -> a -> Bool
>Int
maxWidth) (forall a b. [a] -> [b] -> [(a, b)]
zip (forall {a}. [[(a, Symbol)]] -> [Int]
runningWidth [[(State, Symbol)]]
aksharas) [[(State, Symbol)]]
aksharas) of
            ([], []) -> []
            ([[(State, Symbol)]]
pre, []) -> [forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(State, Symbol)]]
pre]
            ([], [(State, Symbol)]
post:[[(State, Symbol)]]
posts) -> [(State, Symbol)]
post forall a. a -> [a] -> [a]
: [[(State, Symbol)]] -> [[(State, Symbol)]]
go [[(State, Symbol)]]
posts
            ([[(State, Symbol)]]
pre, [[(State, Symbol)]]
post) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(State, Symbol)]]
pre forall a. a -> [a] -> [a]
: [[(State, Symbol)]] -> [[(State, Symbol)]]
go [[(State, Symbol)]]
post
    -- drop 1 so it's the width at the end of each section.
    runningWidth :: [[(a, Symbol)]] -> [Int]
runningWidth = forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Symbol -> Int
symLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))

-- ** formatting

data Symbol = Symbol {
    Symbol -> Text
_text :: !Text
    , Symbol -> Style
_style :: !Styled.Style
    -- | If this was from a S.Sustain, which comes from S.hasSustain.  This
    -- differentiates a stroke followed by rests from a sequence that continues
    -- over a time range.
    , Symbol -> Bool
_isSustain :: !Bool
    , Symbol -> Bool
_emphasize :: !Bool
    , Symbol -> Maybe (Highlight, Color)
_highlight :: !(Maybe (Format.Highlight, Styled.Color))
    -- | True if this is the non-first part of a Symbol split via
    -- overlapSymbols.  This is so that Format.formatFinalAvartanam can
    -- consider it a single symbol.
    , Symbol -> Bool
_isOverlappingSymbol :: !Bool
    } deriving (Symbol -> Symbol -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Symbol -> Symbol -> Bool
$c/= :: Symbol -> Symbol -> Bool
== :: Symbol -> Symbol -> Bool
$c== :: Symbol -> Symbol -> Bool
Eq, Int -> Symbol -> ShowS
[Symbol] -> ShowS
Symbol -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Symbol] -> ShowS
$cshowList :: [Symbol] -> ShowS
show :: Symbol -> String
$cshow :: Symbol -> String
showsPrec :: Int -> Symbol -> ShowS
$cshowsPrec :: Int -> Symbol -> ShowS
Show)

instance Pretty Symbol where
    pretty :: Symbol -> Text
pretty (Symbol Text
text Style
_style Bool
_isSustain Bool
emphasize Maybe (Highlight, Color)
highlight Bool
_) =
        Text
text forall a. Semigroup a => a -> a -> a
<> (if Bool
emphasize then Text
"(b)" else Text
"")
        forall a. Semigroup a => a -> a -> a
<> case Maybe (Highlight, Color)
highlight of
            Maybe (Highlight, Color)
Nothing -> Text
""
            Just (Highlight
Format.StartHighlight, Color
_) -> Text
"+"
            Just (Highlight
Format.Highlight, Color
_) -> Text
"-"
            Just (Highlight
Format.EndHighlight, Color
_) -> Text
"|"

formatSymbol :: Symbol -> Styled.Styled
formatSymbol :: Symbol -> Styled
formatSymbol (Symbol Text
text Style
style Bool
_isSustain Bool
emph Maybe (Highlight, Color)
highlight Bool
_) =
    (case Maybe (Highlight, Color)
highlight of
        Maybe (Highlight, Color)
Nothing -> forall a. a -> a
id
        Just (Highlight
Format.StartHighlight, Color
color) -> forall a. ToStyled a => Color -> a -> Styled
Styled.bg Color
color
        Just (Highlight
_, Color
color) -> forall a. ToStyled a => Color -> a -> Styled
Styled.bg Color
color
    ) forall a b. (a -> b) -> a -> b
$
    forall a. ToStyled a => Style -> a -> Styled
Styled.styled Style
style forall a b. (a -> b) -> a -> b
$ (if Bool
emph then Text -> Styled
emphasize else Text -> Styled
Styled.plain) Text
text
    where
    emphasize :: Text -> Styled
emphasize Text
word
        -- A bold _ looks similar to a non-bold one, so put a bar to make it
        -- more obvious.
        | Text
"_ " Text -> Text -> Bool
`Text.isPrefixOf` Text
word = Text -> Styled
emphasize Text
"_|"
        | Text
"‗ " Text -> Text -> Bool
`Text.isPrefixOf` Text
word = Text -> Styled
emphasize Text
"‗|"
        | Bool
otherwise = Text -> Styled
emphasisStyle Text
word

emphasisStyle :: Text -> Styled.Styled
emphasisStyle :: Text -> Styled
emphasisStyle = forall a. ToStyled a => Color -> a -> Styled
Styled.fg Color
red forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStyled a => a -> Styled
Styled.bold
    where red :: Color
red = Float -> Float -> Float -> Color
Styled.rgb (Float
0xa1 forall a. Fractional a => a -> a -> a
/ Float
0xff) (Float
0x13 forall a. Fractional a => a -> a -> a
/ Float
0xff) Float
0
    -- I'm used to this dark red since it's what iterm used for bold.

symLength :: Symbol -> Int
symLength :: Symbol -> Int
symLength = Text -> Int
Realize.textLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
_text

textSplitAt :: Int -> Text -> (Text, Text)
textSplitAt :: Int -> Text -> (Text, Text)
textSplitAt Int
at Text
text =
    [(Text, Text)] -> (Text, Text)
find forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Text -> (Text, Text)
Text.splitAt Text
text) [Int
0 .. Text -> Int
Realize.textLength Text
text]
    where
    find :: [(Text, Text)] -> (Text, Text)
find ((Text, Text)
cur : next :: [(Text, Text)]
next@((Text
pre, Text
_) : [(Text, Text)]
_))
        | Text -> Int
Realize.textLength Text
pre forall a. Ord a => a -> a -> Bool
> Int
at = (Text, Text)
cur
        | Bool
otherwise = [(Text, Text)] -> (Text, Text)
find [(Text, Text)]
next
    find [(Text, Text)]
_ = (Text
text, Text
"")

-- * util

breakFst :: (key -> Bool) -> [(key, a)] -> ([a], [a])
breakFst :: forall key a. (key -> Bool) -> [(key, a)] -> ([a], [a])
breakFst key -> Bool
f = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break (key -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

-- | I think lenses are the way to lift mapAccumL into second.
mapAccumLSnd :: (state -> a -> (state, b)) -> state -> [(x, a)]
    -> (state, [(x, b)])
mapAccumLSnd :: forall state a b x.
(state -> a -> (state, b))
-> state -> [(x, a)] -> (state, [(x, b)])
mapAccumLSnd state -> a -> (state, b)
f state
state = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL state -> (x, a) -> (state, (x, b))
f2 state
state
    where
    f2 :: state -> (x, a) -> (state, (x, b))
f2 state
state (x
x, a
a) = (state
state2, (x
x, b
b))
        where (state
state2, b
b) = state -> a -> (state, b)
f state
state a
a