{-|

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
(IntervalText a -> IntervalText a -> Bool)
-> (IntervalText a -> IntervalText a -> Bool)
-> Eq (IntervalText a)
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
[IntervalText a] -> ShowS
IntervalText a -> String
(Int -> IntervalText a -> ShowS)
-> (IntervalText a -> String)
-> ([IntervalText a] -> ShowS)
-> Show (IntervalText a)
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 = PairedInterval Char a -> IntervalText a
forall a. PairedInterval Char a -> IntervalText a
MkIntervalText (PairedInterval Char a -> IntervalText a)
-> (Interval a -> PairedInterval Char a)
-> Interval a
-> IntervalText a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Interval a -> PairedInterval Char a
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) = PairedInterval Char a -> Interval a
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 = PairedInterval Char b -> IntervalText b
forall a. PairedInterval Char a -> IntervalText a
MkIntervalText (PairedInterval Char b -> IntervalText b)
-> PairedInterval Char b -> IntervalText b
forall a b. (a -> b) -> a -> b
$ PairedInterval Char a -> Interval b -> PairedInterval Char 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) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (b -> Int
forall a. Enum a => a -> Int
fromEnum (Interval a -> b
forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i) =>
i a -> b
duration Interval a
i)) Char
c
   where
    c :: Char
c = PairedInterval Char a -> Char
forall b a. PairedInterval b a -> b
getPairData PairedInterval Char a
x
    i :: Interval a
i = PairedInterval Char a -> Interval a
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
[IntervalTextLine a] -> ShowS
IntervalTextLine a -> String
(Int -> IntervalTextLine a -> ShowS)
-> (IntervalTextLine a -> String)
-> ([IntervalTextLine a] -> ShowS)
-> Show (IntervalTextLine a)
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]
_) =
    (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(<>) ((IntervalText Int -> Doc ann) -> [IntervalText Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntervalText Int
x -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent (IntervalText Int -> Int
forall (i :: * -> *) a. Intervallic i => i a -> a
begin IntervalText Int
x) (IntervalText Int -> Doc ann
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) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ IntervalTextLineParseError -> String
forall a. Show a => a -> String
show IntervalTextLineParseError
e
  pretty (Right IntervalTextLine Int
l) = IntervalTextLine Int -> Doc ann
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
(IntervalTextLineParseError -> IntervalTextLineParseError -> Bool)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Bool)
-> Eq IntervalTextLineParseError
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
(Int -> IntervalTextLineParseError -> ShowS)
-> (IntervalTextLineParseError -> String)
-> ([IntervalTextLineParseError] -> ShowS)
-> Show IntervalTextLineParseError
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
Eq IntervalTextLineParseError
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Ordering)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Bool)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Bool)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Bool)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> Bool)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> IntervalTextLineParseError)
-> (IntervalTextLineParseError
    -> IntervalTextLineParseError -> IntervalTextLineParseError)
-> Ord 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 = [IntervalText Int] -> Maybe (NonEmpty (IntervalText Int))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [IntervalText Int]
l
  in  if
        | ((IntervalText Int, IntervalText Int) -> Bool)
-> [(IntervalText Int, IntervalText Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((IntervalText Int -> IntervalText Int -> Bool)
-> (IntervalText Int, IntervalText Int) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IntervalText Int -> IntervalText Int -> Bool
forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
concur) ([IntervalText Int] -> [(IntervalText Int, IntervalText Int)]
forall {a}. [a] -> [(a, a)]
pairs [IntervalText Int]
l) -> IntervalTextLineParseError
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. a -> Either a b
Left IntervalTextLineParseError
ConcurringIntervals
        | (Bool -> Bool
not (Bool -> Bool)
-> ([IntervalText Int] -> Bool) -> [IntervalText Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Interval Int] -> Bool
forall {b}. Ord b => [b] -> Bool
isSorted ([Interval Int] -> Bool)
-> ([IntervalText Int] -> [Interval Int])
-> [IntervalText Int]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntervalText Int -> Interval Int)
-> [IntervalText Int] -> [Interval Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntervalText Int -> Interval Int
forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval) [IntervalText Int]
l -> IntervalTextLineParseError
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. a -> Either a b
Left IntervalTextLineParseError
UnsortedIntervals
        | (IntervalText Int -> Bool) -> [IntervalText Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (Int -> Bool)
-> (IntervalText Int -> Int) -> IntervalText Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalText Int -> Int
forall (i :: * -> *) a. Intervallic i => i a -> a
begin) [IntervalText Int]
l -> IntervalTextLineParseError
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. a -> Either a b
Left IntervalTextLineParseError
BeginsLessThanZero
        | Bool
otherwise -> case Maybe (NonEmpty (IntervalText Int))
vals of
          Maybe (NonEmpty (IntervalText Int))
Nothing -> IntervalTextLine Int
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. b -> Either a b
Right ([IntervalText Int] -> [Text] -> IntervalTextLine Int
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
            IntervalTextLine Int
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. b -> Either a b
Right (IntervalTextLine Int
 -> Either IntervalTextLineParseError (IntervalTextLine Int))
-> IntervalTextLine Int
-> Either IntervalTextLineParseError (IntervalTextLine Int)
forall a b. (a -> b) -> a -> b
$ [IntervalText Int] -> [Text] -> IntervalTextLine Int
forall a. [IntervalText a] -> [Text] -> IntervalTextLine a
MkIntervalTextLine (NonEmpty (IntervalText Int) -> [IntervalText Int]
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 =
    NonEmpty (IntervalText Int) -> IntervalText Int
forall a. NonEmpty a -> a
NE.head NonEmpty (IntervalText Int)
x IntervalText Int
-> [IntervalText Int] -> NonEmpty (IntervalText Int)
forall a. a -> [a] -> NonEmpty a
NE.:| (IntervalText Int -> IntervalText Int -> IntervalText Int)
-> [IntervalText Int] -> [IntervalText Int] -> [IntervalText Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith IntervalText Int -> IntervalText Int -> IntervalText Int
forall a b (i1 :: * -> *) (i0 :: * -> *).
(IntervalSizeable a b, Intervallic i1, Intervallic i0) =>
i0 a -> i1 a -> i1 b
shiftFromEnd (NonEmpty (IntervalText Int) -> [IntervalText Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (IntervalText Int)
x) (NonEmpty (IntervalText Int) -> [IntervalText Int]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty (IntervalText Int)
x)

  -- Creates all pairs of a list
  pairs :: [a] -> [(a, a)]
pairs = [a] -> [(a, a)]
forall {a}. [a] -> [(a, a)]
go
   where
    go :: [a] -> [(a, a)]
go []       = []
    go (a
x : [a]
xs) = (a -> (a, a)) -> [a] -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x, ) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. Semigroup a => a -> a -> a
<> [a] -> [(a, a)]
go [a]
xs
  isSorted :: [b] -> Bool
isSorted [b]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (b -> b -> Bool) -> [b] -> [b] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> b -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [b]
xs ([b] -> [b]
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
(AxisPlacement -> AxisPlacement -> Bool)
-> (AxisPlacement -> AxisPlacement -> Bool) -> Eq AxisPlacement
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
(Int -> AxisPlacement -> ShowS)
-> (AxisPlacement -> String)
-> ([AxisPlacement] -> ShowS)
-> Show AxisPlacement
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
(AxisLabels -> AxisLabels -> Bool)
-> (AxisLabels -> AxisLabels -> Bool) -> Eq AxisLabels
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
(Int -> AxisLabels -> ShowS)
-> (AxisLabels -> String)
-> ([AxisLabels] -> ShowS)
-> Show AxisLabels
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
(AxisConfig -> AxisConfig -> Bool)
-> (AxisConfig -> AxisConfig -> Bool) -> Eq AxisConfig
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
(Int -> AxisConfig -> ShowS)
-> (AxisConfig -> String)
-> ([AxisConfig] -> ShowS)
-> Show AxisConfig
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 = ((Int, a) -> (Int, a) -> Ordering)
-> NonEmpty (Int, a) -> NonEmpty (Int, a)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (\(Int
k, a
_) (Int
k', a
_) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
k Int
k')
  (NonEmpty (Int, a) -> NonEmpty (Int, a))
-> (NonEmpty (Int, a) -> NonEmpty (Int, a))
-> NonEmpty (Int, a)
-> NonEmpty (Int, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> (Int, a) -> Bool)
-> NonEmpty (Int, a) -> NonEmpty (Int, a)
forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
NE.nubBy (\(Int
k, a
_) (Int
k', a
_) -> Int
k Int -> Int -> Bool
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 = NonEmpty (Int, Char) -> NonEmpty (Int, Char)
forall a. NonEmpty (Int, a) -> NonEmpty (Int, a)
intMapList NonEmpty (Int, Char)
labs
  let ints :: NonEmpty Int
ints       = ((Int, Char) -> Int) -> NonEmpty (Int, Char) -> NonEmpty Int
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Int, Char) -> Int
forall a b. (a, b) -> a
fst NonEmpty (Int, Char)
labssorted
  let marks :: String
marks      = NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char -> String) -> NonEmpty Char -> String
forall a b. (a -> b) -> a -> b
$ ((Int, Char) -> Char) -> NonEmpty (Int, Char) -> NonEmpty Char
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Int, Char) -> Char
forall a b. (a, b) -> b
snd NonEmpty (Int, Char)
labssorted
  let labPos :: [Int]
labPos =
        NonEmpty Int -> Int
forall a. NonEmpty a -> a
NE.head NonEmpty Int
ints Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
x Int
y -> Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (NonEmpty Int -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Int
ints) (NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty Int
ints)
  let out :: [Doc ann]
out =
        [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Int -> Doc ann) -> [Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
i (Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'|')) [Int]
labPos
        , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Int -> Doc ann -> Doc ann) -> [Int] -> [Doc ann] -> [Doc ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent [Int]
labPos (Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Char -> Doc ann) -> String -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
marks)
        ]
  case AxisPlacement
pos of
    AxisPlacement
Top    -> [Doc ann] -> [Doc ann]
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
(Axis -> Axis -> Bool) -> (Axis -> Axis -> Bool) -> Eq Axis
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
(Int -> Axis -> ShowS)
-> (Axis -> String) -> ([Axis] -> ShowS) -> Show Axis
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
_      )) = Doc ann
forall ann. Doc ann
emptyDoc
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
_) Maybe AxisLabels
Nothing)) = IntervalText Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
ref
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
Bottom) (Just AxisLabels
labels))) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ IntervalText Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntervalText Int
ref Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: AxisPlacement -> AxisLabels -> [Doc ann]
forall ann. AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
Bottom AxisLabels
labels
  pretty (MkAxis IntervalText Int
ref (MkAxisConfig (Just AxisPlacement
Top) (Just AxisLabels
labels))) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ AxisPlacement -> AxisLabels -> [Doc ann]
forall ann. AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
Top AxisLabels
labels [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [IntervalText Int -> Doc ann
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) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ AxisParseError -> String
forall a. Show a => a -> String
show AxisParseError
e
  pretty (Right Axis
a) = Axis -> Doc ann
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
(AxisParseError -> AxisParseError -> Bool)
-> (AxisParseError -> AxisParseError -> Bool) -> Eq AxisParseError
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
(Int -> AxisParseError -> ShowS)
-> (AxisParseError -> String)
-> ([AxisParseError] -> ShowS)
-> Show AxisParseError
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 = Axis -> Either AxisParseError Axis
forall a b. b -> Either a b
Right (Axis -> Either AxisParseError Axis)
-> Axis -> Either AxisParseError Axis
forall a b. (a -> b) -> a -> b
$ IntervalText Int -> AxisConfig -> Axis
MkAxis IntervalText Int
i (Maybe AxisPlacement -> Maybe AxisLabels -> AxisConfig
MkAxisConfig Maybe AxisPlacement
forall a. Maybe a
Nothing Maybe AxisLabels
forall a. Maybe a
Nothing)
parseAxis [(Int, Char)]
l (Just AxisPlacement
p) IntervalText Int
i = do
  let labels :: Maybe (NonEmpty (Int, Char))
labels          = NonEmpty (Int, Char) -> NonEmpty (Int, Char)
forall a. NonEmpty (Int, a) -> NonEmpty (Int, a)
intMapList (NonEmpty (Int, Char) -> NonEmpty (Int, Char))
-> Maybe (NonEmpty (Int, Char)) -> Maybe (NonEmpty (Int, Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Char)] -> Maybe (NonEmpty (Int, Char))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(Int, Char)]
l
  let labPos :: Maybe (NonEmpty Int)
labPos          = ((Int, Char) -> Int) -> NonEmpty (Int, Char) -> NonEmpty Int
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Int, Char) -> Int
forall a b. (a, b) -> a
fst (NonEmpty (Int, Char) -> NonEmpty Int)
-> Maybe (NonEmpty (Int, Char)) -> Maybe (NonEmpty Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NonEmpty (Int, Char))
labels
  let inputLabelCount :: Int
inputLabelCount = [(Int, Char)] -> Int
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
      (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
x -> Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< IntervalText Int -> Int
forall (i :: * -> *) a. Intervallic i => i a -> a
begin IntervalText Int
i Bool -> Bool -> Bool
|| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> IntervalText Int -> Int
forall (i :: * -> *) a. Intervallic i => i a -> a
end IntervalText Int
i) (((Int, Char) -> Int) -> [(Int, Char)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Char) -> Int
forall a b. (a, b) -> a
fst [(Int, Char)]
l) -> AxisParseError -> Either AxisParseError Axis
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (NonEmpty (Int, Char) -> Int)
-> Maybe (NonEmpty (Int, Char)) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Int, Char) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe (NonEmpty (Int, Char))
labels Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Maybe Int
forall a. a -> Maybe a
Just Int
inputLabelCount -> AxisParseError -> Either AxisParseError Axis
forall a b. a -> Either a b
Left
      AxisParseError
MultipleLabelAtSamePosition
    |
-- Otherwise, we have a good Axis.
      Bool
otherwise -> Axis -> Either AxisParseError Axis
forall a b. b -> Either a b
Right
    (Axis -> Either AxisParseError Axis)
-> Axis -> Either AxisParseError Axis
forall a b. (a -> b) -> a -> b
$  IntervalText Int -> AxisConfig -> Axis
MkAxis IntervalText Int
i (Maybe AxisPlacement -> Maybe AxisLabels -> AxisConfig
MkAxisConfig (AxisPlacement -> Maybe AxisPlacement
forall a. a -> Maybe a
Just AxisPlacement
p) ((NonEmpty (Int, Char) -> AxisLabels)
-> Maybe (NonEmpty (Int, Char)) -> Maybe AxisLabels
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
(IntervalDiagramOptions -> IntervalDiagramOptions -> Bool)
-> (IntervalDiagramOptions -> IntervalDiagramOptions -> Bool)
-> Eq IntervalDiagramOptions
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
(Int -> IntervalDiagramOptions -> ShowS)
-> (IntervalDiagramOptions -> String)
-> ([IntervalDiagramOptions] -> ShowS)
-> Show IntervalDiagramOptions
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
(IntervalDiagramOptionsError
 -> IntervalDiagramOptionsError -> Bool)
-> (IntervalDiagramOptionsError
    -> IntervalDiagramOptionsError -> Bool)
-> Eq IntervalDiagramOptionsError
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
(Int -> IntervalDiagramOptionsError -> ShowS)
-> (IntervalDiagramOptionsError -> String)
-> ([IntervalDiagramOptionsError] -> ShowS)
-> Show IntervalDiagramOptionsError
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0                       -> IntervalDiagramOptionsError
-> Either IntervalDiagramOptionsError IntervalDiagramOptions
forall a b. a -> Either a b
Left IntervalDiagramOptionsError
LeftPaddingLessThan0
  | LayoutOptions -> PageWidth
layoutPageWidth (IntervalDiagramOptions -> LayoutOptions
layout IntervalDiagramOptions
opts) PageWidth -> PageWidth -> Bool
forall a. Eq a => a -> a -> Bool
== PageWidth
Unbounded -> IntervalDiagramOptionsError
-> Either IntervalDiagramOptionsError IntervalDiagramOptions
forall a b. a -> Either a b
Left IntervalDiagramOptionsError
UnboundedPageWidth
  | Bool
otherwise                                  -> IntervalDiagramOptions
-> Either IntervalDiagramOptionsError IntervalDiagramOptions
forall a b. b -> Either a b
Right IntervalDiagramOptions
opts
  where isSorted :: [b] -> Bool
isSorted [b]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (b -> b -> Bool) -> [b] -> [b] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> b -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [b]
xs ([b] -> [b]
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
[IntervalDiagram a] -> ShowS
IntervalDiagram a -> String
(Int -> IntervalDiagram a -> ShowS)
-> (IntervalDiagram a -> String)
-> ([IntervalDiagram a] -> ShowS)
-> Show (IntervalDiagram a)
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
(IntervalDiagramParseError -> IntervalDiagramParseError -> Bool)
-> (IntervalDiagramParseError -> IntervalDiagramParseError -> Bool)
-> Eq IntervalDiagramParseError
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
(Int -> IntervalDiagramParseError -> ShowS)
-> (IntervalDiagramParseError -> String)
-> ([IntervalDiagramParseError] -> ShowS)
-> Show IntervalDiagramParseError
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 = (IntervalTextLine Int -> Doc ann)
-> [IntervalTextLine Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntervalTextLine Int -> Doc ann
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        = IntervalText Int -> Int
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  = (IntervalTextLine Int -> Int) -> [IntervalTextLine Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a b. IntervalSizeable a b => a -> a -> b
diff Int
refDur (Int -> Int)
-> (IntervalTextLine Int -> Int) -> IntervalTextLine Int -> Int
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 =
          (IntervalTextLine Int -> Int -> Doc ann)
-> [IntervalTextLine Int] -> [Int] -> [Doc ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\IntervalTextLine Int
i Int
l -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
l (IntervalTextLine Int -> Doc ann
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 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Doc ann -> Doc ann -> Doc ann)
-> [Doc ann] -> [Doc ann] -> [Doc ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc ann -> Doc ann -> Doc ann
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 (AxisConfig -> Maybe AxisPlacement)
-> (Axis -> AxisConfig) -> Axis -> Maybe AxisPlacement
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    -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Axis -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Axis
axis, Doc ann
intervalDiagram]
          Just AxisPlacement
Bottom -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
intervalDiagram, Axis -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Axis
axis]

    -- Add any left padding.
    Int -> Doc ann -> Doc ann
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]
_) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (IntervalText Int -> Int) -> [IntervalText Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IntervalText Int -> Int
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 [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
t
      then Doc ann
forall ann. Doc ann
emptyDoc
      else Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text
"<-" :: Text) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Text] -> Doc ann
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) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ IntervalDiagramParseError -> String
forall a. Show a => a -> String
show IntervalDiagramParseError
e
  pretty (Right IntervalDiagram a
d) = IntervalDiagram a -> Doc ann
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 -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left (IntervalDiagramParseError
 -> Either IntervalDiagramParseError (IntervalDiagram a))
-> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
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 (LayoutOptions -> PageWidth) -> LayoutOptions -> PageWidth
forall a b. (a -> b) -> a -> b
$ IntervalDiagramOptions -> LayoutOptions
layout IntervalDiagramOptions
o)
      -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left IntervalDiagramParseError
AxisWiderThanAvailable
      |
-- check none of the interval extend beyond the reference interval
        (IntervalText a -> Bool) -> [IntervalText a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ComparativePredicateOf2 (IntervalText a) (IntervalText a)
extendsBeyond IntervalText a
ref) ((([IntervalText a], [Text]) -> [IntervalText a])
-> [([IntervalText a], [Text])] -> [IntervalText a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([IntervalText a], [Text]) -> [IntervalText a]
forall a b. (a, b) -> a
fst [([IntervalText a], [Text])]
ivs)
      -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left IntervalDiagramParseError
IntervalsExtendBeyondAxis
      |
-- check that padding == 0 and axis is displayed
        IntervalDiagramOptions -> Int
leftPadding IntervalDiagramOptions
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Maybe AxisPlacement -> Bool
forall a. Maybe a -> Bool
isNothing Maybe AxisPlacement
placement
      -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left IntervalDiagramParseError
PaddingWithNoAxis
      | Bool
otherwise
      -> let parsedReferencedIntervals :: Either IntervalTextLineParseError [IntervalTextLine Int]
parsedReferencedIntervals = (([IntervalText a], [Text])
 -> Either IntervalTextLineParseError (IntervalTextLine Int))
-> [([IntervalText a], [Text])]
-> Either IntervalTextLineParseError [IntervalTextLine Int]
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 (IntervalText a -> [IntervalText a] -> [IntervalText Int]
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 -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left (IntervalDiagramParseError
 -> Either IntervalDiagramParseError (IntervalDiagram a))
-> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
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 (IntervalText a -> IntervalText a -> IntervalText Int
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 -> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left (IntervalDiagramParseError
 -> Either IntervalDiagramParseError (IntervalDiagram a))
-> IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. (a -> b) -> a -> b
$ AxisParseError -> IntervalDiagramParseError
AxisError AxisParseError
e
                       Right Axis
axis ->
                         IntervalDiagram a
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. b -> Either a b
Right (IntervalDiagram a
 -> Either IntervalDiagramParseError (IntervalDiagram a))
-> IntervalDiagram a
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. (a -> b) -> a -> b
$ Interval a
-> Axis
-> [IntervalTextLine Int]
-> IntervalDiagramOptions
-> IntervalDiagram a
forall a.
Interval a
-> Axis
-> [IntervalTextLine Int]
-> IntervalDiagramOptions
-> IntervalDiagram a
MkIntervalDiagram (IntervalText a -> Interval a
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 =
    ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
before ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall a (i0 :: * -> *) (i1 :: * -> *).
(Eq a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
meets ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlaps ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall a (i0 :: * -> *) (i1 :: * -> *).
(Ord a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlappedBy ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall a (i0 :: * -> *) (i1 :: * -> *).
(Eq a, Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
metBy ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) (i1 :: * -> *) a.
(Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText 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
_) = b -> Int
forall a. Enum a => a -> Int
fromEnum (IntervalText a -> b
forall a b (i :: * -> *).
(IntervalSizeable a b, Intervallic i) =>
i a -> b
duration IntervalText a
ref) Int -> Int -> Bool
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 = i a -> i Int
forall a (i :: * -> *). (Enum a, Intervallic i) => i a -> i Int
fromEnumInterval (i a -> i Int) -> (i a -> i a) -> i a -> i Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i0 a -> i a -> i a
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 = (i a -> i Int) -> f (i a) -> f (i Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i0 a -> i a -> i Int
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 = IntervalDiagramOptions
-> [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText a
-> [([IntervalText a], [Text])]
-> Either IntervalDiagramParseError (IntervalDiagram a)
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
  []
  (AxisPlacement -> Maybe AxisPlacement
forall a. a -> Maybe a
Just AxisPlacement
Bottom)
  (Char -> Interval a -> IntervalText a
forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'=' (i a -> Interval a
forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval i a
ref))
  ((i a -> ([IntervalText a], [Text]))
-> [i a] -> [([IntervalText a], [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\i a
x -> (IntervalText a -> [IntervalText a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntervalText a -> [IntervalText a])
-> IntervalText a -> [IntervalText a]
forall a b. (a -> b) -> a -> b
$ Char -> Interval a -> IntervalText a
forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'-' (Interval a -> IntervalText a) -> Interval a -> IntervalText a
forall a b. (a -> b) -> a -> b
$ i a -> Interval a
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     = IntervalDiagramParseError
-> Either IntervalDiagramParseError (IntervalDiagram a)
forall a b. a -> Either a b
Left IntervalDiagramParseError
IntervalsExtendBeyondAxis
  op (Just IntervalText a
ref') = IntervalDiagramOptions
-> [(Int, Char)]
-> Maybe AxisPlacement
-> IntervalText a
-> [([IntervalText a], [Text])]
-> Either IntervalDiagramParseError (IntervalDiagram a)
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
                                        []
                                        (AxisPlacement -> Maybe AxisPlacement
forall a. a -> Maybe a
Just AxisPlacement
Bottom)
                                        IntervalText a
ref'
                                        [([IntervalText a], [Text])]
combIvs
  range :: Maybe (Interval a)
range         = [Interval a] -> Maybe (Interval a)
forall a (t :: * -> *).
(Ord a, Foldable t) =>
t (Interval a) -> Maybe (Interval a)
rangeInterval ([Interval a] -> Maybe (Interval a))
-> [Interval a] -> Maybe (Interval a)
forall a b. (a -> b) -> a -> b
$ ((Interval a, String) -> Interval a)
-> [(Interval a, String)] -> [Interval a]
forall a b. (a -> b) -> [a] -> [b]
map (Interval a, String) -> Interval a
forall a b. (a, b) -> a
fst [(Interval a, String)]
ivs [Interval a] -> [Interval a] -> [Interval a]
forall a. [a] -> [a] -> [a]
++ (([Interval a], String) -> [Interval a])
-> [([Interval a], String)] -> [Interval a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Interval a], String) -> [Interval a]
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  -> Maybe (Interval a)
forall a. Maybe a
Nothing
    (Just Interval a
x) -> Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just (Interval a -> Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall a b. (a -> b) -> a -> b
$ (a, a) -> Interval a
forall a b. IntervalSizeable a b => (a, a) -> Interval a
safeInterval (a -> a -> a
forall a. Ord a => a -> a -> a
min (Interval a -> a
forall (i :: * -> *) a. Intervallic i => i a -> a
begin Interval a
x) a
0, a -> a -> a
forall a. Ord a => a -> a -> a
max (Interval a -> a
forall (i :: * -> *) a. Intervallic i => i a -> a
end Interval a
x) a
0)
  ref :: Maybe (IntervalText a)
ref = (Interval a -> IntervalText a)
-> Maybe (Interval a) -> Maybe (IntervalText a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Interval a -> IntervalText a
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) = ((Interval a -> IntervalText a) -> [Interval a] -> [IntervalText a]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Interval a -> IntervalText a
forall a. Char -> Interval a -> IntervalText a
makeIntervalText Char
'-') [Interval a]
ivs, [String -> Text
pack String
s])
  combIvs :: [([IntervalText a], [Text])]
combIvs = ((Interval a, String) -> ([IntervalText a], [Text]))
-> [(Interval a, String)] -> [([IntervalText a], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (([Interval a], String) -> ([IntervalText a], [Text])
forall {a}. ([Interval a], String) -> ([IntervalText a], [Text])
g (([Interval a], String) -> ([IntervalText a], [Text]))
-> ((Interval a, String) -> ([Interval a], String))
-> (Interval a, String)
-> ([IntervalText a], [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Interval a, String) -> ([Interval a], String)
forall {a} {b}. (a, b) -> ([a], b)
f) [(Interval a, String)]
ivs [([IntervalText a], [Text])]
-> [([IntervalText a], [Text])] -> [([IntervalText a], [Text])]
forall a. [a] -> [a] -> [a]
++ (([Interval a], String) -> ([IntervalText a], [Text]))
-> [([Interval a], String)] -> [([IntervalText a], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map ([Interval a], String) -> ([IntervalText a], [Text])
forall {a}. ([Interval a], String) -> ([IntervalText a], [Text])
g [([Interval a], String)]
livs