{-|

This module provides functions for creating diagrams of intervals as text.
For example,

>>> let ref = bi 30 (0 :: Int)
>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]
>>> pretty $ simpleIntervalDiagram ref ivs
--
          -----
                ------
==============================

>>> let ref = bi 30 (fromGregorian 2022 5 6)
>>> let ivs = [ bi 2 (fromGregorian 2022 5 6), bi 5 (fromGregorian 2022 5 10)]
>>> pretty $ simpleIntervalDiagram ref ivs
--
    -----
==============================

Such diagrams are useful for documentation, examples,
and learning to reason with the interval algebra.

There are two main functions available:

* @'parseIntervalDiagram'@:
exposes all available options
and gives the most flexibility in producing diagrams
* @'simpleIntervalDiagram'@
produces simple diagram using defaults.
-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE UndecidableInstances  #-}

module IntervalAlgebra.IntervalDiagram
  (
  -- * Make nice-looking diagrams of intervals
  {-|
  All these functions return an @'IntervalDiagram'@,
  which can then be pretty printed using the @'Prettyprinter.pretty'@ function.
  -}
    parseIntervalDiagram
  , simpleIntervalDiagram
  , standardExampleDiagram

  -- * Diagram options
  , IntervalDiagramOptions(..)
  , defaultIntervalDiagramOptions
  , AxisPlacement(..)

  -- * Internal types
  , IntervalText
  , IntervalDiagram

  -- * Errors
  , IntervalTextLineParseError(..)
  , AxisParseError(..)
  , IntervalDiagramOptionsError(..)
  , IntervalDiagramParseError(..)

  -- * Re-exports
  , Prettyprinter.Pretty(..)
  ) where

import           Data.Foldable                     (Foldable (toList))
import qualified Data.List.NonEmpty                as NE hiding (toList)
import           Data.Maybe                        (fromMaybe, isNothing)
import           Data.Text                         (Text, pack)
import           IntervalAlgebra.Core
import           IntervalAlgebra.IntervalUtilities (rangeInterval)
import           IntervalAlgebra.PairedInterval    (PairedInterval, getPairData,
                                                    makePairedInterval)
import           Prettyprinter

-- $setup
-- >>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings
-- >>> import IntervalAlgebra.IntervalUtilities (gapsWithin)
-- >>> import Data.Time

{-
The key Type in this module is the IntervalDiagram,
which has several components.
Each component in sections below organized as follows:
 * Type(s)
 * (optional) Instances
 * (optional) parser
 * (optional) utilities
-}

{-------------------------------------------------------------------------------
  IntervalText
-------------------------------------------------------------------------------}

{-|
@IntervalText@ is an internal type
which contains an @Interval a@ and the @Char@ used to print
the interval in a diagram.

>>> pretty $ makeIntervalText '-' (beginerval 5 (0::Int))
-----
>>> pretty $ makeIntervalText '*' (beginerval 10 (0::Int))
**********
-}

newtype IntervalText a = MkIntervalText (PairedInterval Char a) deriving (IntervalText a -> IntervalText a -> Bool
forall a. Eq a => IntervalText a -> IntervalText a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalText a -> IntervalText a -> Bool
$c/= :: forall a. Eq a => IntervalText a -> IntervalText a -> Bool
== :: IntervalText a -> IntervalText a -> Bool
$c== :: forall a. Eq a => IntervalText a -> IntervalText a -> Bool
Eq, Int -> IntervalText a -> ShowS
forall a. (Show a, Ord a) => Int -> IntervalText a -> ShowS
forall a. (Show a, Ord a) => [IntervalText a] -> ShowS
forall a. (Show a, Ord a) => IntervalText a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalText a] -> ShowS
$cshowList :: forall a. (Show a, Ord a) => [IntervalText a] -> ShowS
show :: IntervalText a -> String
$cshow :: forall a. (Show a, Ord a) => IntervalText a -> String
showsPrec :: Int -> IntervalText a -> ShowS
$cshowsPrec :: forall a. (Show a, Ord a) => Int -> IntervalText a -> ShowS
Show)

makeIntervalText :: Char -> Interval a -> IntervalText a
makeIntervalText :: forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
c = forall a. PairedInterval Char a -> IntervalText a
MkIntervalText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval Char
c

instance Intervallic IntervalText where
  getInterval :: forall a. IntervalText a -> Interval a
getInterval (MkIntervalText PairedInterval Char a
x) = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval Char a
x
  setInterval :: forall a b. IntervalText a -> Interval b -> IntervalText b
setInterval (MkIntervalText PairedInterval Char a
x) Interval b
i = forall a. PairedInterval Char a -> IntervalText a
MkIntervalText forall a b. (a -> b) -> a -> b
$ forall (i :: * -> *) a b. Intervallic i => i a -> Interval b -> i b
setInterval PairedInterval Char a
x Interval b
i

instance (Enum b, IntervalSizeable a b) => Pretty (IntervalText a) where
  pretty :: forall ann. IntervalText a -> Doc ann
pretty (MkIntervalText PairedInterval Char a
x) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall a. Enum a => a -> Int
fromEnum (forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i) =>
i a -> b
duration Interval a
i)) Char
c
   where
    c :: Char
c = forall b a. PairedInterval b a -> b
getPairData PairedInterval Char a
x
    i :: Interval a
i = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval Char a
x

{-------------------------------------------------------------------------------
  IntervalTextLine
-------------------------------------------------------------------------------}

{-|
The @IntervalTextLine@ is an internal type
containing a list of @IntervalText@.

Values of this type should only be created
through the 'parseIntervalTextLine' function,
which checks that the inputs are parsed correctly to form intervals
that will be pretty-printed correctly.

>>> let i1 =  makeIntervalText '*' (beginerval 10 (5::Int))
>>> let i2  = makeIntervalText '-' (beginerval 2 (1::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
UnsortedIntervals
>>> let i1 =  makeIntervalText '*' (beginerval 10 (5::Int))
>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
ConcurringIntervals
>>> let i1 =  makeIntervalText '*' (beginerval 10 ((-1)::Int))
>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine []  [i1, i2]
>>> pretty x
BeginsLessThanZero
>>> let i1 =  makeIntervalText '*' (beginerval  5 (0::Int))
>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
*****     --
>>> let i1 =  makeIntervalText '*' (beginerval  5 (5::Int))
>>> let i2  = makeIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
     *****--
>>> let i1 =  makeIntervalText '*' (beginerval  1 (5::Int))
>>> let i2  = makeIntervalText '-' (beginerval 1 (7::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
     * -
>>> let i1 =  makeIntervalText '*' (beginerval  3 (5::Int))
>>> let i2 = makeIntervalText '-' (beginerval 5 (10::Int))
>>> let i3 = makeIntervalText '#' (beginerval 1 17)
>>> pretty $ parseIntervalTextLine [] [i1, i2, i3]
     ***  -----  #
-}
data IntervalTextLine a = MkIntervalTextLine [IntervalText a] [Text]
  deriving Int -> IntervalTextLine a -> ShowS
forall a. (Show a, Ord a) => Int -> IntervalTextLine a -> ShowS
forall a. (Show a, Ord a) => [IntervalTextLine a] -> ShowS
forall a. (Show a, Ord a) => IntervalTextLine a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalTextLine a] -> ShowS
$cshowList :: forall a. (Show a, Ord a) => [IntervalTextLine a] -> ShowS
show :: IntervalTextLine a -> String
$cshow :: forall a. (Show a, Ord a) => IntervalTextLine a -> String
showsPrec :: Int -> IntervalTextLine a -> ShowS
$cshowsPrec :: forall a. (Show a, Ord a) => Int -> IntervalTextLine a -> ShowS
Show

{-
NOTE:
a pretty-printed @IntervalTextLine@ does not print its labels.
Line labels are printed by @IntervalDiagram@.
This is because line labels are vertically aligned across lines,
and without the other lines we don't know where to align labels.
-}
instance Pretty (IntervalTextLine Int) where
  pretty :: forall ann. IntervalTextLine Int -> Doc ann
pretty (MkIntervalTextLine [IntervalText Int]
ivs [Text]
_) =
    forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith forall a. Semigroup a => a -> a -> a
(<>) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntervalText Int
x -> forall ann. Int -> Doc ann -> Doc ann
indent (forall (i :: * -> *) a. Intervallic i => i a -> a
begin IntervalText Int
x) (forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
x)) [IntervalText Int]
ivs)

instance Pretty (Either IntervalTextLineParseError (IntervalTextLine Int)) where
  pretty :: forall ann.
Either IntervalTextLineParseError (IntervalTextLine Int) -> Doc ann
pretty (Left  IntervalTextLineParseError
e) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show IntervalTextLineParseError
e
  pretty (Right IntervalTextLine Int
l) = forall a ann. Pretty a => a -> Doc ann
pretty IntervalTextLine Int
l

{-|
A type representing errors that may occur
when a list of @IntervalText@ is parsed into a @IntervalTextLine@.
-}
data IntervalTextLineParseError =
    -- | The inputs contains concurring intervals.
    --   All inputs should be @'disjoint'@.
      ConcurringIntervals
    -- | The inputs are not sorted.
    | UnsortedIntervals
    -- | At least one of the inputs has a @'begin'@ less than zero.
    | BeginsLessThanZero
     deriving (IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c/= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
== :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c== :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
Eq, Int -> IntervalTextLineParseError -> ShowS
[IntervalTextLineParseError] -> ShowS
IntervalTextLineParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalTextLineParseError] -> ShowS
$cshowList :: [IntervalTextLineParseError] -> ShowS
show :: IntervalTextLineParseError -> String
$cshow :: IntervalTextLineParseError -> String
showsPrec :: Int -> IntervalTextLineParseError -> ShowS
$cshowsPrec :: Int -> IntervalTextLineParseError -> ShowS
Show, Eq IntervalTextLineParseError
IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
IntervalTextLineParseError
-> IntervalTextLineParseError -> Ordering
IntervalTextLineParseError
-> IntervalTextLineParseError -> IntervalTextLineParseError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IntervalTextLineParseError
-> IntervalTextLineParseError -> IntervalTextLineParseError
$cmin :: IntervalTextLineParseError
-> IntervalTextLineParseError -> IntervalTextLineParseError
max :: IntervalTextLineParseError
-> IntervalTextLineParseError -> IntervalTextLineParseError
$cmax :: IntervalTextLineParseError
-> IntervalTextLineParseError -> IntervalTextLineParseError
>= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c>= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
> :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c> :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
<= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c<= :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
< :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
$c< :: IntervalTextLineParseError -> IntervalTextLineParseError -> Bool
compare :: IntervalTextLineParseError
-> IntervalTextLineParseError -> Ordering
$ccompare :: IntervalTextLineParseError
-> IntervalTextLineParseError -> Ordering
Ord)

{-|
Parses a list of @IntervalText Int@
into an @IntervalTextLine Int@,
handling the types of parse errors that could occur.

See 'IntervalTextLine' for examples.
-}
parseIntervalTextLine
  :: [Text]
  -> [IntervalText Int]
  -> Either IntervalTextLineParseError (IntervalTextLine Int)
parseIntervalTextLine :: [Text]
-> [IntervalText Int]
-> Either IntervalTextLineParseError (IntervalTextLine Int)
parseIntervalTextLine [Text]
labs [IntervalText Int]
l =
  let vals :: Maybe (NonEmpty (IntervalText Int))
vals = forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [IntervalText Int]
l
  in  if
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
concur) (forall {a}. [a] -> [(a, a)]
pairs [IntervalText Int]
l) -> forall a b. a -> Either a b
Left IntervalTextLineParseError
ConcurringIntervals
        | (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Ord b => [b] -> Bool
isSorted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval) [IntervalText Int]
l -> forall a b. a -> Either a b
Left IntervalTextLineParseError
UnsortedIntervals
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
< Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (i :: * -> *) a. Intervallic i => i a -> a
begin) [IntervalText Int]
l -> forall a b. a -> Either a b
Left IntervalTextLineParseError
BeginsLessThanZero
        | Bool
otherwise -> case Maybe (NonEmpty (IntervalText Int))
vals of
          Maybe (NonEmpty (IntervalText Int))
Nothing -> forall a b. b -> Either a b
Right (forall a. [IntervalText a] -> [Text] -> IntervalTextLine a
MkIntervalTextLine [] [])
          Just NonEmpty (IntervalText Int)
v ->
            -- The use of makeIntervalLine is important here
            -- in order to get the intervals positioned correctly
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [IntervalText a] -> [Text] -> IntervalTextLine a
MkIntervalTextLine (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (IntervalText Int) -> NonEmpty (IntervalText Int)
makeIntervalLine NonEmpty (IntervalText Int)
v)) [Text]
labs
 where
  {-
  Modifies the inputs sequentially
  so that the begin of one interval is
  shifted based on the end of the previous interval.
  This function assumes that the inputs are sorted and disjoint.
  -}
  makeIntervalLine
    :: NE.NonEmpty (IntervalText Int) -> NE.NonEmpty (IntervalText Int)
  makeIntervalLine :: NonEmpty (IntervalText Int) -> NonEmpty (IntervalText Int)
makeIntervalLine NonEmpty (IntervalText Int)
x =
    forall a. NonEmpty a -> a
NE.head NonEmpty (IntervalText Int)
x forall a. a -> [a] -> NonEmpty a
NE.:| forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b (i1 :: * -> *) (i0 :: * -> *).
(IntervalSizeable a b, Intervallic i1, Intervallic i0) =>
i0 a -> i1 a -> i1 b
shiftFromEnd (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (IntervalText Int)
x) (forall a. NonEmpty a -> [a]
NE.tail NonEmpty (IntervalText Int)
x)

  -- Creates all pairs of a list
  pairs :: [a] -> [(a, a)]
pairs = forall {a}. [a] -> [(a, a)]
go
   where
    go :: [a] -> [(a, a)]
go []       = []
    go (a
x : [a]
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x, ) [a]
xs forall a. Semigroup a => a -> a -> a
<> [a] -> [(a, a)]
go [a]
xs
  isSorted :: [b] -> Bool
isSorted [b]
xs = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<=) [b]
xs (forall a. [a] -> [a]
tail [b]
xs)


{-------------------------------------------------------------------------------
  Axis Config and Components
-------------------------------------------------------------------------------}

{-|
A type representing options of where to place the axis in a printed diagram.
-}
data AxisPlacement =
  -- | Print the axis at the top of the diagram
    Top
  -- | Print the axis at the bottom of the diagram
  | Bottom deriving (AxisPlacement -> AxisPlacement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AxisPlacement -> AxisPlacement -> Bool
$c/= :: AxisPlacement -> AxisPlacement -> Bool
== :: AxisPlacement -> AxisPlacement -> Bool
$c== :: AxisPlacement -> AxisPlacement -> Bool
Eq, Int -> AxisPlacement -> ShowS
[AxisPlacement] -> ShowS
AxisPlacement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AxisPlacement] -> ShowS
$cshowList :: [AxisPlacement] -> ShowS
show :: AxisPlacement -> String
$cshow :: AxisPlacement -> String
showsPrec :: Int -> AxisPlacement -> ShowS
$cshowsPrec :: Int -> AxisPlacement -> ShowS
Show)

{-|
Key-value list data that can be presented below the axis on an
@IntervalDiagram@. First element of the tuple is an Int key, the second the
Char to print. Note that it does not guarantee uniqueness of the keys, and most
if not all functions should first call @intMapList@ on the internal
@NE.NonEmpty@ list before using this type.
-}
newtype AxisLabels = MkAxisLabels (NE.NonEmpty (Int, Char))
  deriving (AxisLabels -> AxisLabels -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AxisLabels -> AxisLabels -> Bool
$c/= :: AxisLabels -> AxisLabels -> Bool
== :: AxisLabels -> AxisLabels -> Bool
$c== :: AxisLabels -> AxisLabels -> Bool
Eq, Int -> AxisLabels -> ShowS
[AxisLabels] -> ShowS
AxisLabels -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AxisLabels] -> ShowS
$cshowList :: [AxisLabels] -> ShowS
show :: AxisLabels -> String
$cshow :: AxisLabels -> String
showsPrec :: Int -> AxisLabels -> ShowS
$cshowsPrec :: Int -> AxisLabels -> ShowS
Show)

{-|
A type containing information on
how to configure the axis of an 'IntervalDiagram'.
-}
data AxisConfig = MkAxisConfig
  { AxisConfig -> Maybe AxisPlacement
placement :: Maybe AxisPlacement
  , AxisConfig -> Maybe AxisLabels
labels    :: Maybe AxisLabels
  }
  deriving (AxisConfig -> AxisConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AxisConfig -> AxisConfig -> Bool
$c/= :: AxisConfig -> AxisConfig -> Bool
== :: AxisConfig -> AxisConfig -> Bool
$c== :: AxisConfig -> AxisConfig -> Bool
Eq, Int -> AxisConfig -> ShowS
[AxisConfig] -> ShowS
AxisConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AxisConfig] -> ShowS
$cshowList :: [AxisConfig] -> ShowS
show :: AxisConfig -> String
$cshow :: AxisConfig -> String
showsPrec :: Int -> AxisConfig -> ShowS
$cshowsPrec :: Int -> AxisConfig -> ShowS
Show)

-- Internal utility to give equivalent structure to IntMap from
-- Data.IntMap.NonEmpty for the key-value list in @AxisLabels@. Previously,
-- when using IntMap for the @AxisLabels@ container, uniqueness and ordering of
-- keys was guaranteed. Now, you should first call this function before using
-- those keys, e.g. in @prettyAxisLabels@, to get the same properties. This has
-- a runtime cost and could be rewritten for efficiency if that were a concern.
-- NOTE: NE does not have a sortOn.
intMapList :: NE.NonEmpty (Int, a) -> NE.NonEmpty (Int, a)
intMapList :: forall a. NonEmpty (Int, a) -> NonEmpty (Int, a)
intMapList = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (\(Int
k, a
_) (Int
k', a
_) -> forall a. Ord a => a -> a -> Ordering
compare Int
k Int
k')
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
NE.nubBy (\(Int
k, a
_) (Int
k', a
_) -> Int
k forall a. Eq a => a -> a -> Bool
== Int
k')

prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels :: forall ann. AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
pos (MkAxisLabels NonEmpty (Int, Char)
labs) = do
  let labssorted :: NonEmpty (Int, Char)
labssorted = forall a. NonEmpty (Int, a) -> NonEmpty (Int, a)
intMapList NonEmpty (Int, Char)
labs
  let ints :: NonEmpty Int
ints       = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a b. (a, b) -> a
fst NonEmpty (Int, Char)
labssorted
  let marks :: String
marks      = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a b. (a, b) -> b
snd NonEmpty (Int, Char)
labssorted
  let labPos :: [Int]
labPos =
        forall a. NonEmpty a -> a
NE.head NonEmpty Int
ints forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
x Int
y -> Int
y forall a. Num a => a -> a -> a
- Int
x forall a. Num a => a -> a -> a
- Int
1) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Int
ints) (forall a. NonEmpty a -> [a]
NE.tail NonEmpty Int
ints)
  let out :: [Doc ann]
out =
        [ forall ann. [Doc ann] -> Doc ann
hcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> forall ann. Int -> Doc ann -> Doc ann
indent Int
i (forall a ann. Pretty a => a -> Doc ann
pretty Char
'|')) [Int]
labPos
        , forall ann. [Doc ann] -> Doc ann
hcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall ann. Int -> Doc ann -> Doc ann
indent [Int]
labPos (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
marks)
        ]
  case AxisPlacement
pos of
    AxisPlacement
Top    -> forall a. [a] -> [a]
reverse [Doc ann]
out
    AxisPlacement
Bottom -> [Doc ann]
out

{-------------------------------------------------------------------------------
  Axis
-------------------------------------------------------------------------------}

{-|
A type containing the data necessary to print an axis in an 'IntervalDiagram'.

Use 'parseAxis' for construction.

>>> let ref = makeIntervalText '=' (beginerval 10 (0::Int))


>>> let b = parseAxis [] (Just Top) ref
>>> pretty b
==========

>>> let c = parseAxis [(4, 'a'), (6, 'b')] (Just Top) ref
>>> pretty c
    a b
    | |
==========

>>> let d = parseAxis [(4, 'a'), (6, 'b')] (Just Bottom) ref
>>> pretty d
==========
    | |
    a b

>>> let e = parseAxis [(4, 'a'), (4, 'b')] (Just Top) ref
>>> pretty e
MultipleLabelAtSamePosition

>>> let f = parseAxis [(4, 'a'), (19, 'b')] (Just Top) ref
>>> pretty f
LabelsBeyondReference

-}
data Axis = MkAxis
  { Axis -> IntervalText Int
refInterval :: IntervalText Int
  , Axis -> AxisConfig
config      :: AxisConfig
  }
  deriving (Axis -> Axis -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Axis -> Axis -> Bool
$c/= :: Axis -> Axis -> Bool
== :: Axis -> Axis -> Bool
$c== :: Axis -> Axis -> Bool
Eq, Int -> Axis -> ShowS
[Axis] -> ShowS
Axis -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Axis] -> ShowS
$cshowList :: [Axis] -> ShowS
show :: Axis -> String
$cshow :: Axis -> String
showsPrec :: Int -> Axis -> ShowS
$cshowsPrec :: Int -> Axis -> ShowS
Show)

instance Pretty Axis where
  pretty :: forall ann. Axis -> Doc ann
pretty (MkAxis IntervalText Int
ref (MkAxisConfig Maybe AxisPlacement
Nothing  Maybe AxisLabels
_      )) = forall ann. Doc ann
emptyDoc
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
_) Maybe AxisLabels
Nothing)) = forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
ref
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
Bottom) (Just AxisLabels
labels))) =
    forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
ref forall a. a -> [a] -> [a]
: forall ann. AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
Bottom AxisLabels
labels
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
Top) (Just AxisLabels
labels))) =
    forall ann. [Doc ann] -> Doc ann
vcat forall a b. (a -> b) -> a -> b
$ forall ann. AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
Top AxisLabels
labels forall a. [a] -> [a] -> [a]
++ [forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
ref]

instance Pretty ( Either AxisParseError Axis ) where
  pretty :: forall ann. Either AxisParseError Axis -> Doc ann
pretty (Left  AxisParseError
e) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show AxisParseError
e
  pretty (Right Axis
a) = forall a ann. Pretty a => a -> Doc ann
pretty Axis
a

{-|
A type representing errors that can occur when parsing an axis.
-}
data AxisParseError =
  -- | Indicates that the position of one ore more axis labels
  --   is outside the reference interval
    LabelsBeyondReference
  -- | Indicates that multiple labels have been put at the same position
  | MultipleLabelAtSamePosition
  deriving (AxisParseError -> AxisParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AxisParseError -> AxisParseError -> Bool
$c/= :: AxisParseError -> AxisParseError -> Bool
== :: AxisParseError -> AxisParseError -> Bool
$c== :: AxisParseError -> AxisParseError -> Bool
Eq, Int -> AxisParseError -> ShowS
[AxisParseError] -> ShowS
AxisParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AxisParseError] -> ShowS
$cshowList :: [AxisParseError] -> ShowS
show :: AxisParseError -> String
$cshow :: AxisParseError -> String
showsPrec :: Int -> AxisParseError -> ShowS
$cshowsPrec :: Int -> AxisParseError -> ShowS
Show)

{-|
Safely create an @Axis@.

See @Axis@ for examples.
-}
parseAxis
  :: [(Int, Char)]
  -> Maybe AxisPlacement
  -> IntervalText Int
  -> Either AxisParseError Axis
-- if the axis is not shown then any labels are ignored
parseAxis :: [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText Int
-> Either AxisParseError Axis
parseAxis [(Int, Char)]
_ Maybe AxisPlacement
Nothing  IntervalText Int
i = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IntervalText Int -> AxisConfig -> Axis
MkAxis IntervalText Int
i (Maybe AxisPlacement -> Maybe AxisLabels -> AxisConfig
MkAxisConfig forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
parseAxis [(Int, Char)]
l (Just AxisPlacement
p) IntervalText Int
i = do
  let labels :: Maybe (NonEmpty (Int, Char))
labels          = forall a. NonEmpty (Int, a) -> NonEmpty (Int, a)
intMapList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, Char)]
l
  let labPos :: Maybe (NonEmpty Int)
labPos          = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NonEmpty (Int, Char))
labels
  let inputLabelCount :: Int
inputLabelCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Char)]
l
  if
    |
-- Flag if any of the label positions are beyond the reference interval
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
x -> Int
x forall a. Ord a => a -> a -> Bool
< forall (i :: * -> *) a. Intervallic i => i a -> a
begin IntervalText Int
i Bool -> Bool -> Bool
|| Int
x forall a. Ord a => a -> a -> Bool
> forall (i :: * -> *) a. Intervallic i => i a -> a
end IntervalText Int
i) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Int, Char)]
l) -> forall a b. a -> Either a b
Left
      AxisParseError
LabelsBeyondReference
    |
-- Identify if the number of elements in the input list is different
-- from the number of elements after transforming the list
-- into a nonempty IntMap.
-- If different, then flag.
      Int
inputLabelCount forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe (NonEmpty (Int, Char))
labels forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Int
inputLabelCount -> forall a b. a -> Either a b
Left
      AxisParseError
MultipleLabelAtSamePosition
    |
-- Otherwise, we have a good Axis.
      Bool
otherwise -> forall a b. b -> Either a b
Right
    forall a b. (a -> b) -> a -> b
$  IntervalText Int -> AxisConfig -> Axis
MkAxis IntervalText Int
i (Maybe AxisPlacement -> Maybe AxisLabels -> AxisConfig
MkAxisConfig (forall a. a -> Maybe a
Just AxisPlacement
p) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Int, Char) -> AxisLabels
MkAxisLabels Maybe (NonEmpty (Int, Char))
labels))

{-------------------------------------------------------------------------------
  IntervalDiagramOptions
-------------------------------------------------------------------------------}

{-|
A record containing options for printing an @'IntervalDiagram'@.
-}
data IntervalDiagramOptions = MkIntervalDiagramOptions
  { -- | See 'PrettyPrinter.LayoutOptions'
    IntervalDiagramOptions -> LayoutOptions
layout      :: LayoutOptions
    -- | Number of spaces to pad the left of the diagram by.
    --   Must be greater than or equal to @0@.
  , IntervalDiagramOptions -> Int
leftPadding :: Int
  }
  deriving (IntervalDiagramOptions -> IntervalDiagramOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalDiagramOptions -> IntervalDiagramOptions -> Bool
$c/= :: IntervalDiagramOptions -> IntervalDiagramOptions -> Bool
== :: IntervalDiagramOptions -> IntervalDiagramOptions -> Bool
$c== :: IntervalDiagramOptions -> IntervalDiagramOptions -> Bool
Eq, Int -> IntervalDiagramOptions -> ShowS
[IntervalDiagramOptions] -> ShowS
IntervalDiagramOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalDiagramOptions] -> ShowS
$cshowList :: [IntervalDiagramOptions] -> ShowS
show :: IntervalDiagramOptions -> String
$cshow :: IntervalDiagramOptions -> String
showsPrec :: Int -> IntervalDiagramOptions -> ShowS
$cshowsPrec :: Int -> IntervalDiagramOptions -> ShowS
Show)

{-|
A type representing the types of invalid @'IntervalDiagramOptions'@.
-}
data IntervalDiagramOptionsError =
  -- | Indicates that @'PageWidth'@ is @Unbounded@,
  --   which isn't allowed for an IntervalDiagram.
    UnboundedPageWidth
  -- | Indicates that the left padding in the option is < 0.
  | LeftPaddingLessThan0
  deriving (IntervalDiagramOptionsError -> IntervalDiagramOptionsError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalDiagramOptionsError -> IntervalDiagramOptionsError -> Bool
$c/= :: IntervalDiagramOptionsError -> IntervalDiagramOptionsError -> Bool
== :: IntervalDiagramOptionsError -> IntervalDiagramOptionsError -> Bool
$c== :: IntervalDiagramOptionsError -> IntervalDiagramOptionsError -> Bool
Eq, Int -> IntervalDiagramOptionsError -> ShowS
[IntervalDiagramOptionsError] -> ShowS
IntervalDiagramOptionsError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalDiagramOptionsError] -> ShowS
$cshowList :: [IntervalDiagramOptionsError] -> ShowS
show :: IntervalDiagramOptionsError -> String
$cshow :: IntervalDiagramOptionsError -> String
showsPrec :: Int -> IntervalDiagramOptionsError -> ShowS
$cshowsPrec :: Int -> IntervalDiagramOptionsError -> ShowS
Show)

{-|
Takes an initial set of options
and checks that the values are valid,
returning an error if not.

Sorry the indirection in that the input type is also in the output type.
Better might be something like
PossibleOptions -> Either Error ValidOptions
But this works and this code is not exposed to the user.
-}
parseDiagramOptions
  :: IntervalDiagramOptions
  -> Either IntervalDiagramOptionsError IntervalDiagramOptions
parseDiagramOptions :: IntervalDiagramOptions
-> Either IntervalDiagramOptionsError IntervalDiagramOptions
parseDiagramOptions IntervalDiagramOptions
opts = if
  | IntervalDiagramOptions -> Int
leftPadding IntervalDiagramOptions
opts forall a. Ord a => a -> a -> Bool
< Int
0                       -> forall a b. a -> Either a b
Left IntervalDiagramOptionsError
LeftPaddingLessThan0
  | LayoutOptions -> PageWidth
layoutPageWidth (IntervalDiagramOptions -> LayoutOptions
layout IntervalDiagramOptions
opts) forall a. Eq a => a -> a -> Bool
== PageWidth
Unbounded -> forall a b. a -> Either a b
Left IntervalDiagramOptionsError
UnboundedPageWidth
  | Bool
otherwise                                  -> forall a b. b -> Either a b
Right IntervalDiagramOptions
opts
  where isSorted :: [b] -> Bool
isSorted [b]
xs = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<=) [b]
xs (forall a. [a] -> [a]
tail [b]
xs)

-- | Default 'IntervalDiagramOptions' options
defaultIntervalDiagramOptions :: IntervalDiagramOptions
defaultIntervalDiagramOptions :: IntervalDiagramOptions
defaultIntervalDiagramOptions = LayoutOptions -> Int -> IntervalDiagramOptions
MkIntervalDiagramOptions LayoutOptions
defaultLayoutOptions Int
0

{-------------------------------------------------------------------------------
  IntervalDiagram
-------------------------------------------------------------------------------}

{-|
Type containing the data needed to pretty print an interval document.
-}
data IntervalDiagram a = MkIntervalDiagram
  { -- | The reference interval is the interval based on which 'intervalValues'
   --    are transformed.
   --    It is the only interval that retains the original type.
    forall a. IntervalDiagram a -> Interval a
reference      :: Interval a
  , forall a. IntervalDiagram a -> Axis
axis           :: Axis
  , forall a. IntervalDiagram a -> [IntervalTextLine Int]
intervalValues :: [IntervalTextLine Int]
  , forall a. IntervalDiagram a -> IntervalDiagramOptions
options        :: IntervalDiagramOptions
  }
  deriving Int -> IntervalDiagram a -> ShowS
forall a. (Show a, Ord a) => Int -> IntervalDiagram a -> ShowS
forall a. (Show a, Ord a) => [IntervalDiagram a] -> ShowS
forall a. (Show a, Ord a) => IntervalDiagram a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalDiagram a] -> ShowS
$cshowList :: forall a. (Show a, Ord a) => [IntervalDiagram a] -> ShowS
show :: IntervalDiagram a -> String
$cshow :: forall a. (Show a, Ord a) => IntervalDiagram a -> String
showsPrec :: Int -> IntervalDiagram a -> ShowS
$cshowsPrec :: forall a. (Show a, Ord a) => Int -> IntervalDiagram a -> ShowS
Show

{-|
Type representing errors that may occur
when parsing inputs into an @'IntervalDiagram'@.

Not every possible state of a "bad" diagram is currently captured
by 'parseIntervalDiagram'.
In particular, line labels can be a source of problems.
The labels accept arbitrary @Text@.
Newline characters in a label would, for example, throw things off.
Labels that extend beyond the @'PrettyPrinter.pageWidth'@
will also cause problems.

-}
data IntervalDiagramParseError =
  -- | Indicates that one or more of the input intervals extend beyond the axis.
    IntervalsExtendBeyondAxis
  -- | Indicates that the reference axis is longer than the @'PageWidth'@
  --   given in the @'IntervalDiagramOptions'@.
  | AxisWiderThanAvailable
  -- | Indicates that left padding is >0
  --   and no axis is printed.
  --   This is considered an error because it be impossible
  --   to know the 'begin' values of intervals in a printed @IntervalDiagram@
  --   that has been padded and has no axis.
  | PaddingWithNoAxis
  -- | Indicates that an error occurring when checking the document options.
  | OptionsError IntervalDiagramOptionsError
  -- | Indicates something is wrong with the @Axis@.
  | AxisError AxisParseError
  -- | Indicates that at least one error occurred when parsing the interval lines.
  | IntervalLineError IntervalTextLineParseError
  deriving (IntervalDiagramParseError -> IntervalDiagramParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalDiagramParseError -> IntervalDiagramParseError -> Bool
$c/= :: IntervalDiagramParseError -> IntervalDiagramParseError -> Bool
== :: IntervalDiagramParseError -> IntervalDiagramParseError -> Bool
$c== :: IntervalDiagramParseError -> IntervalDiagramParseError -> Bool
Eq, Int -> IntervalDiagramParseError -> ShowS
[IntervalDiagramParseError] -> ShowS
IntervalDiagramParseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalDiagramParseError] -> ShowS
$cshowList :: [IntervalDiagramParseError] -> ShowS
show :: IntervalDiagramParseError -> String
$cshow :: IntervalDiagramParseError -> String
showsPrec :: Int -> IntervalDiagramParseError -> ShowS
$cshowsPrec :: Int -> IntervalDiagramParseError -> ShowS
Show)

instance (IntervalSizeable a b) => Pretty (IntervalDiagram a) where
  pretty :: forall ann. IntervalDiagram a -> Doc ann
pretty (MkIntervalDiagram Interval a
_ Axis
axis [IntervalTextLine Int]
ivs IntervalDiagramOptions
opts) = do

    -- Create a list of pretty IntervalLines
    let intervalLines :: [Doc ann]
intervalLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a ann. Pretty a => a -> Doc ann
pretty [IntervalTextLine Int]
ivs

    -- Get the length of the reference interval
    -- in order to determine the column position of line labels
    let refDur :: Int
refDur        = forall (i :: * -> *) a. Intervallic i => i a -> a
end (Axis -> IntervalText Int
refInterval Axis
axis)

    -- Position line labels relative to the reference interval
    -- and the end of the last interval in a line.
    -- NOTE:
    -- This is tricky because the intervals
    -- in a parsed IntervalTextLine are referenced relative
    -- to the previous interval in the line,
    -- not to the reference interval.
    -- See use of makeIntervalLine in parseIntervalTextLine.
    -- This why the intervalLineEnd function is used to determine
    -- the end of the intervals in a line.
    let labelIndents :: [Int]
labelIndents  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. IntervalSizeable a b => a -> a -> b
diff Int
refDur forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalTextLine Int -> Int
intervalLineEnd) [IntervalTextLine Int]
ivs

    -- Create a list of the line label docs
    let labelLines :: [Doc ann]
labelLines =
          forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\IntervalTextLine Int
i Int
l -> forall ann. Int -> Doc ann -> Doc ann
indent Int
l (forall ann. IntervalTextLine Int -> Doc ann
prettyLineLabel IntervalTextLine Int
i)) [IntervalTextLine Int]
ivs [Int]
labelIndents

    -- Zip together each interval line and its labels horizontally,
    -- then stack all the lines.
    let intervalDiagram :: Doc ann
intervalDiagram = forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Semigroup a => a -> a -> a
(<>) [Doc ann]
intervalLines [Doc ann]
labelLines

    -- Add the the axis in the appropriate position.
    let mainDiagram :: Doc ann
mainDiagram = case (AxisConfig -> Maybe AxisPlacement
placement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Axis -> AxisConfig
config) Axis
axis of
          Maybe AxisPlacement
Nothing     -> Doc ann
intervalDiagram
          Just AxisPlacement
Top    -> forall ann. [Doc ann] -> Doc ann
vcat [forall a ann. Pretty a => a -> Doc ann
pretty Axis
axis, Doc ann
intervalDiagram]
          Just AxisPlacement
Bottom -> forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
intervalDiagram, forall a ann. Pretty a => a -> Doc ann
pretty Axis
axis]

    -- Add any left padding.
    forall ann. Int -> Doc ann -> Doc ann
indent (IntervalDiagramOptions -> Int
leftPadding IntervalDiagramOptions
opts) Doc ann
mainDiagram

   where
    intervalLineEnd :: IntervalTextLine Int -> Int
    intervalLineEnd :: IntervalTextLine Int -> Int
intervalLineEnd (MkIntervalTextLine [IntervalText Int]
x [Text]
_) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (i :: * -> *) a. Intervallic i => i a -> a
end [IntervalText Int]
x

    prettyLineLabel :: IntervalTextLine Int -> Doc ann
    prettyLineLabel :: forall ann. IntervalTextLine Int -> Doc ann
prettyLineLabel (MkIntervalTextLine [IntervalText Int]
_ [Text]
t) = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
t
      then forall ann. Doc ann
emptyDoc
      else forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (Text
"<-" :: Text) forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
space forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Text]
t

instance (IntervalSizeable a b) =>
  Pretty (Either IntervalDiagramParseError (IntervalDiagram a)) where
  pretty :: forall ann.
Either IntervalDiagramParseError (IntervalDiagram a) -> Doc ann
pretty (Left  IntervalDiagramParseError
e) = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show IntervalDiagramParseError
e
  pretty (Right IntervalDiagram a
d) = forall a ann. Pretty a => a -> Doc ann
pretty IntervalDiagram a
d

{-|
Parse inputs into a pretty printable document.

This function provides the most flexibility in producing interval diagrams.

Here's a basic diagram that shows
how to put more than one interval interval on a line:

>>> let mkIntrvl c d b = makeIntervalText c (bi d (b :: Int))
>>> let x = mkIntrvl  '=' 20 0
>>> let l1 = [ mkIntrvl '-' 1 4 ]
>>> let l2 = [ mkIntrvl '*' 3 5, mkIntrvl '*' 5 10, mkIntrvl 'x' 1 17 ]
>>> let l3 = [ mkIntrvl '#' 2 18]
>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions  [] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]
    -
     ***  *****  x
                  ##
====================


We can put the axis on the top:

>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Top) x [ (l1, []), (l2, []), (l3, []) ]
====================
    -
     ***  *****  x
                  ##


We can annotate the axis:

>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [(5, 'a')] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]
    -
     ***  *****  x
                  ##
====================
     |
     a


We can also annotate each line with labels:

>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Bottom) x [ (l1, ["line1"]), (l2, ["line2a", "line2b"]), (l3, ["line3"])  ]
    -                <- [line1]
     ***  *****  x   <- [line2a, line2b]
                  ## <- [line3]
====================


The parser tries to check that the data can be printed.
For example, the default @'Prettyprinter.LayoutOptions'@ is 80 characters.
Providing an reference interval wider than 80 characters
results in an error.

>>> let x = mkIntrvl '=' 100 5
>>> let ivs = [ mkIntrvl '-' 1 1 ]
>>> parseIntervalDiagram defaultIntervalDiagramOptions [] Nothing x [ (ivs, []) ]
Left AxisWiderThanAvailable

See 'IntervalDiagramParseError' for all the cases handled.

-}
parseIntervalDiagram
  :: (Ord a, IntervalSizeable a b, Enum b)
  => IntervalDiagramOptions
  -- ^ Document options (see 'IntervalDiagramOptions')
  -> [(Int, Char)]
  -- ^ A list of axis labels
  -> Maybe AxisPlacement
  -- ^ An optional 'AxisPlacement' of the axis
  -> IntervalText a
  -- ^ The reference (axis interval)
  -> [([IntervalText a], [Text])]
  -- ^ Intervals to include in the diagram.
  -- Each item in the list creates a new line in the printed diagram.
  -- Text creates an optional label for the line.
  -> Either IntervalDiagramParseError (IntervalDiagram a)
parseIntervalDiagram :: forall a b.
(Ord a, IntervalSizeable a b, Enum b) =>
IntervalDiagramOptions
-> [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText a
-> [([IntervalText a], [Text])]
-> Either IntervalDiagramParseError (IntervalDiagram a)
parseIntervalDiagram IntervalDiagramOptions
opts [(Int, Char)]
labels Maybe AxisPlacement
placement IntervalText a
ref [([IntervalText a], [Text])]
ivs =
  case IntervalDiagramOptions
-> Either IntervalDiagramOptionsError IntervalDiagramOptions
parseDiagramOptions IntervalDiagramOptions
opts of
    Left  IntervalDiagramOptionsError
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IntervalDiagramOptionsError -> IntervalDiagramParseError
OptionsError IntervalDiagramOptionsError
e
    Right IntervalDiagramOptions
o -> if
      |
-- check that the duration of the reference intervall
-- does not exceed the page width
        PageWidth -> Bool
checkAvailableChar (LayoutOptions -> PageWidth
layoutPageWidth forall a b. (a -> b) -> a -> b
$ IntervalDiagramOptions -> LayoutOptions
layout IntervalDiagramOptions
o)
      -> forall a b. a -> Either a b
Left IntervalDiagramParseError
AxisWiderThanAvailable
      |
-- check none of the interval extend beyond the reference interval
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ComparativePredicateOf2 (IntervalText a) (IntervalText a)
extendsBeyond IntervalText a
ref) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([IntervalText a], [Text])]
ivs)
      -> forall a b. a -> Either a b
Left IntervalDiagramParseError
IntervalsExtendBeyondAxis
      |
-- check that padding == 0 and axis is displayed
        IntervalDiagramOptions -> Int
leftPadding IntervalDiagramOptions
o forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe AxisPlacement
placement
      -> forall a b. a -> Either a b
Left IntervalDiagramParseError
PaddingWithNoAxis
      | Bool
otherwise
      -> let parsedReferencedIntervals :: Either IntervalTextLineParseError [IntervalTextLine Int]
parsedReferencedIntervals = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
               (\([IntervalText a]
i, [Text]
t) -> [Text]
-> [IntervalText Int]
-> Either IntervalTextLineParseError (IntervalTextLine Int)
parseIntervalTextLine [Text]
t (forall {f :: * -> *} {a} {a} {i :: * -> *} {i0 :: * -> *}.
(Functor f, Enum a, IntervalSizeable a a, Intervallic i,
 Intervallic i0) =>
i0 a -> f (i a) -> f (i Int)
rereferenceL IntervalText a
ref [IntervalText a]
i))
               [([IntervalText a], [Text])]
ivs
         in  case Either IntervalTextLineParseError [IntervalTextLine Int]
parsedReferencedIntervals of
               Left IntervalTextLineParseError
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IntervalTextLineParseError -> IntervalDiagramParseError
IntervalLineError IntervalTextLineParseError
e
               Right [IntervalTextLine Int]
vals ->
                 let parsedAxis :: Either AxisParseError Axis
parsedAxis =
                       [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText Int
-> Either AxisParseError Axis
parseAxis [(Int, Char)]
labels Maybe AxisPlacement
placement (forall {a} {a} {i :: * -> *} {i0 :: * -> *}.
(Enum a, IntervalSizeable a a, Intervallic i, Intervallic i0) =>
i0 a -> i a -> i Int
rereference IntervalText a
ref IntervalText a
ref)
                 in  case Either AxisParseError Axis
parsedAxis of
                       Left AxisParseError
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ AxisParseError -> IntervalDiagramParseError
AxisError AxisParseError
e
                       Right Axis
axis ->
                         forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a.
Interval a
-> Axis
-> [IntervalTextLine Int]
-> IntervalDiagramOptions
-> IntervalDiagram a
MkIntervalDiagram (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval IntervalText a
ref) Axis
axis [IntervalTextLine Int]
vals IntervalDiagramOptions
o
 where
  extendsBeyond :: ComparativePredicateOf2 (IntervalText a) (IntervalText a)
extendsBeyond =
    forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
before forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> forall a (i0 :: * -> *) (i1 :: * -> *).
(Eq a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
meets forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlaps forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlappedBy forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> forall a (i0 :: * -> *) (i1 :: * -> *).
(Eq a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
metBy forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
after
  checkAvailableChar :: PageWidth -> Bool
checkAvailableChar (AvailablePerLine Int
i Double
_) = forall a. Enum a => a -> Int
fromEnum (forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i) =>
i a -> b
duration IntervalText a
ref) forall a. Ord a => a -> a -> Bool
> Int
i
  checkAvailableChar PageWidth
Unbounded              = Bool
True
  {-
    Shifts the endpoints of an interval to be referenced from another interval,
    so that the 'begin' of the reference interval acts as the "zero" point.
  -}
  rereference :: i0 a -> i a -> i Int
rereference i0 a
x = forall a (i :: * -> *). (Enum a, Intervallic i) => i a -> i Int
fromEnumInterval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b (i1 :: * -> *) (i0 :: * -> *).
(IntervalSizeable a b, Intervallic i1, Intervallic i0) =>
i0 a -> i1 a -> i1 b
shiftFromBegin i0 a
x
  rereferenceL :: i0 a -> f (i a) -> f (i Int)
rereferenceL i0 a
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {a} {i :: * -> *} {i0 :: * -> *}.
(Enum a, IntervalSizeable a a, Intervallic i, Intervallic i0) =>
i0 a -> i a -> i Int
rereference i0 a
x)

{-|
Given a reference interval and a list of intervals,
produces an 'IntervalDiagram' with one line per interval,
using the 'defaultIntervalDiagramOptions'.

>>> pretty $ simpleIntervalDiagram (bi 10 (0 :: Int)) (fmap (bi 1) [0..9])
-
 -
  -
   -
    -
     -
      -
       -
        -
         -
==========

>>> let ref = bi 30 (0 :: Int)
>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]
>>> pretty $ simpleIntervalDiagram ref ivs
--
          -----
                ------
==============================

>>> pretty $ simpleIntervalDiagram ref (fromMaybe [] (gapsWithin ref ivs))
  --------
               -
                      --------
==============================

-}
simpleIntervalDiagram
  :: (Ord a, IntervalSizeable a b, Intervallic i, Enum b)
  => i a -- ^ The axis interval
  -> [i a] -- ^ List of intervals to be printed one per line
  -> Either IntervalDiagramParseError (IntervalDiagram a)
simpleIntervalDiagram :: forall a b (i :: * -> *).
(Ord a, IntervalSizeable a b, Intervallic i, Enum b) =>
i a
-> [i a] -> Either IntervalDiagramParseError (IntervalDiagram a)
simpleIntervalDiagram i a
ref [i a]
ivs = forall a b.
(Ord a, IntervalSizeable a b, Enum b) =>
IntervalDiagramOptions
-> [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText a
-> [([IntervalText a], [Text])]
-> Either IntervalDiagramParseError (IntervalDiagram a)
parseIntervalDiagram
  IntervalDiagramOptions
defaultIntervalDiagramOptions
  []
  (forall a. a -> Maybe a
Just AxisPlacement
Bottom)
  (forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'=' (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval i a
ref))
  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\i a
x -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'-' forall a b. (a -> b) -> a -> b
$ forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval i a
x, [])) [i a]
ivs)

{- | Given various inputs containing intervals and their label, creates an
interval diagram with labels, along with a reference range that spans all of the
intervals and is extended to include 0 if necesary.

In more detail, an interval diagram is created with one row in the diagram for
each interval and label pair provided as the first input, and followed by a
sequence of additional rows with one row per list element in the second input
and such that each row displays each interval provided in the intervals list and
label pair.

>>> x1 = si (1, 5)
>>> x2 = si (7, 10)
>>> x3 = si (13, 15)
>>> ivs = [x1, x2, x3]
>>> gaps = [si (5, 7), si (10, 13)]
>>> :{
pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gaps, "gaps")]
:}
 ----           <- [x1]
       ---      <- [x2]
             -- <- [x3]
     --   ---   <- [gaps]
===============

>>> :{
pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) []
:}
 ----           <- [x1]
       ---      <- [x2]
             -- <- [x3]
===============

>>> pretty $ standardExampleDiagram [] [(gaps, "gaps")]
     --   --- <- [gaps]
=============

>>> pretty $ standardExampleDiagram [] []
IntervalsExtendBeyondAxis
-}
standardExampleDiagram
  :: (Num a, Ord a, Enum b, IntervalSizeable a b)
  => [(Interval a, String)]
  -> [([Interval a], String)]
  -> Either IntervalDiagramParseError (IntervalDiagram a)
standardExampleDiagram :: forall a b.
(Num a, Ord a, Enum b, IntervalSizeable a b) =>
[(Interval a, String)]
-> [([Interval a], String)]
-> Either IntervalDiagramParseError (IntervalDiagram a)
standardExampleDiagram [(Interval a, String)]
ivs [([Interval a], String)]
livs = Maybe (IntervalText a)
-> Either IntervalDiagramParseError (IntervalDiagram a)
op Maybe (IntervalText a)
ref
 where
  op :: Maybe (IntervalText a)
-> Either IntervalDiagramParseError (IntervalDiagram a)
op Maybe (IntervalText a)
Nothing     = forall a b. a -> Either a b
Left IntervalDiagramParseError
IntervalsExtendBeyondAxis
  op (Just IntervalText a
ref') = forall a b.
(Ord a, IntervalSizeable a b, Enum b) =>
IntervalDiagramOptions
-> [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText a
-> [([IntervalText a], [Text])]
-> Either IntervalDiagramParseError (IntervalDiagram a)
parseIntervalDiagram IntervalDiagramOptions
defaultIntervalDiagramOptions
                                        []
                                        (forall a. a -> Maybe a
Just AxisPlacement
Bottom)
                                        IntervalText a
ref'
                                        [([IntervalText a], [Text])]
combIvs
  range :: Maybe (Interval a)
range         = forall a (t :: * -> *).
(Ord a, Foldable t) =>
t (Interval a) -> Maybe (Interval a)
rangeInterval forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Interval a, String)]
ivs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([Interval a], String)]
livs
  anchoredRange :: Maybe (Interval a)
anchoredRange = case Maybe (Interval a)
range of
    Maybe (Interval a)
Nothing  -> forall a. Maybe a
Nothing
    (Just Interval a
x) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. IntervalSizeable a b => (a, a) -> Interval a
safeInterval (forall a. Ord a => a -> a -> a
min (forall (i :: * -> *) a. Intervallic i => i a -> a
begin Interval a
x) a
0, forall a. Ord a => a -> a -> a
max (forall (i :: * -> *) a. Intervallic i => i a -> a
end Interval a
x) a
0)
  ref :: Maybe (IntervalText a)
ref = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'=') Maybe (Interval a)
anchoredRange
  f :: (a, b) -> ([a], b)
f (a
iv, b
s) = ([a
iv], b
s)
  g :: ([Interval a], String) -> ([IntervalText a], [Text])
g ([Interval a]
ivs, String
s) = (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'-') [Interval a]
ivs, [String -> Text
pack String
s])
  combIvs :: [([IntervalText a], [Text])]
combIvs = forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. ([Interval a], String) -> ([IntervalText a], [Text])
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. (a, b) -> ([a], b)
f) [(Interval a, String)]
ivs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ([Interval a], String) -> ([IntervalText a], [Text])
g [([Interval a], String)]
livs