{-|

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 
--                            
          -----               
                ------        
==============================

>>> import Data.Time
>>> 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 UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GADTs #-}

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

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

  -- * Internal types
  , IntervalText
  , IntervalDiagram

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

import           Data.Foldable                  ( Foldable(toList) )
import qualified Data.IntMap.NonEmpty          as NEM
import qualified Data.List.NonEmpty            as NE
                                         hiding ( toList )
import           Data.Maybe                     ( fromMaybe
                                                , isNothing
                                                )
import           Data.Text                      ( Text )
import           IntervalAlgebra.Core
import           Prettyprinter
import           Witch                          ( From(..)
                                                , into
                                                )

{-
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.

The @Interval a@ type needs to be an instance of @IntervalSizeable a b@;
Moreover, the type @b@ should be castable to @Int@,
using its @'Witch.From' b Int@  instance.

>>> import Prettyprinter (pretty)
>>> import IntervalAlgebra (beginerval)
>>> pretty $ MkIntervalText '-' (beginerval 5 (0::Int))
-----
>>> pretty $ MkIntervalText '*' (beginerval 10 (0::Int))
**********
-}
-- NOTE: This type *could* be a PairedInterval,
-- but I didn't do that in order to reduce depeendencies.
data IntervalText a = MkIntervalText Char (Interval 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)

instance (Ord a) => Intervallic IntervalText a where
  getInterval :: IntervalText a -> Interval a
getInterval (MkIntervalText Char
_ Interval a
x) = Interval a
x
  setInterval :: IntervalText a -> Interval a -> IntervalText a
setInterval (MkIntervalText Char
c Interval a
_) = Char -> Interval a -> IntervalText a
forall a. Char -> Interval a -> IntervalText a
MkIntervalText Char
c

instance Functor IntervalText where
  fmap :: (a -> b) -> IntervalText a -> IntervalText b
fmap a -> b
f (MkIntervalText Char
c Interval a
i) = Char -> Interval b -> IntervalText b
forall a. Char -> Interval a -> IntervalText a
MkIntervalText Char
c ((a -> b) -> Interval a -> Interval b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Interval a
i)

instance (Enum b, IntervalSizeable a b) => Pretty (IntervalText a) where
  pretty :: IntervalText a -> Doc ann
pretty (MkIntervalText Char
c Interval a
i) = 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 a) =>
i a -> b
duration Interval a
i)) Char
c

instance From (Char, Interval a) (IntervalText a) where
  from :: (Char, Interval a) -> IntervalText a
from = (Char -> Interval a -> IntervalText a)
-> (Char, Interval a) -> IntervalText a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Interval a -> IntervalText a
forall a. Char -> Interval a -> IntervalText a
MkIntervalText

instance From (IntervalText a) Char where
  from :: IntervalText a -> Char
from (MkIntervalText Char
c Interval a
_) = Char
c

instance From (IntervalText a) (Interval a) where
  from :: IntervalText a -> Interval a
from (MkIntervalText Char
_ Interval a
i) = Interval a
i

{-------------------------------------------------------------------------------
  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 =  MkIntervalText '*' (beginerval 10 (5::Int))
>>> let i2  = MkIntervalText '-' (beginerval 2 (1::Int))
>>> let x = parseIntervalTextLine [] [i1, i2] 
>>> pretty x
UnsortedIntervals
>>> let i1 =  MkIntervalText '*' (beginerval 10 (5::Int))
>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2] 
>>> pretty x
ConcurringIntervals
>>> let i1 =  MkIntervalText '*' (beginerval 10 ((-1)::Int))
>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine []  [i1, i2] 
>>> pretty x
BeginsLessThanZero
>>> let i1 =  MkIntervalText '*' (beginerval  5 (0::Int))
>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
*****     --
>>> let i1 =  MkIntervalText '*' (beginerval  5 (5::Int))
>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
     *****--
>>> let i1 =  MkIntervalText '*' (beginerval  1 (5::Int))
>>> let i2  = MkIntervalText '-' (beginerval 1 (7::Int))
>>> let x = parseIntervalTextLine [] [i1, i2]
>>> pretty x
     * -
>>> let i1 =  MkIntervalText '*' (beginerval  3 (5::Int))
>>> let i2 = MkIntervalText '-' (beginerval 5 (10::Int))
>>> let i3 = MkIntervalText '#' (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 :: 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 a => 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 :: 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
$cp1Ord :: Eq IntervalTextLineParseError
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 (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
concur) ([IntervalText Int] -> [(IntervalText Int, IntervalText Int)]
forall t. [t] -> [(t, t)]
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 a. Ord a => [a] -> 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 a => 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 a => 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, Functor i1, Intervallic i0 a) =>
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 :: [t] -> [(t, t)]
pairs = [t] -> [(t, t)]
forall t. [t] -> [(t, t)]
go
   where
    go :: [t] -> [(t, t)]
go []       = []
    go (t
x : [t]
xs) = (t -> (t, t)) -> [t] -> [(t, t)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t
x, ) [t]
xs [(t, t)] -> [(t, t)] -> [(t, t)]
forall a. Semigroup a => a -> a -> a
<> [t] -> [(t, t)]
go [t]
xs
  isSorted :: [a] -> Bool
isSorted [a]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> [a] -> [a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [a]
xs ([a] -> [a]
forall a. [a] -> [a]
tail [a]
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)

{-|
Type containing data that can be presented below the axis
on an @IntervalDiagram@.
-}
newtype AxisLabels = MkAxisLabels (NEM.NEIntMap 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)

prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann]
prettyAxisLabels AxisPlacement
pos (MkAxisLabels NEIntMap Char
labs) = do
  let ints :: NonEmpty Int
ints  = NEIntMap Char -> NonEmpty Int
forall a. NEIntMap a -> NonEmpty Int
NEM.keys NEIntMap Char
labs
  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
$ NEIntMap Char -> NonEmpty Char
forall a. NEIntMap a -> NonEmpty a
NEM.elems NEIntMap Char
labs
  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 = MkIntervalText '=' (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 :: 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 :: 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 (NEIntMap Char)
labels          = NonEmpty (Int, Char) -> NEIntMap Char
forall a. NonEmpty (Int, a) -> NEIntMap a
NEM.fromList (NonEmpty (Int, Char) -> NEIntMap Char)
-> Maybe (NonEmpty (Int, Char)) -> Maybe (NEIntMap 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          = NEIntMap Char -> NonEmpty Int
forall a. NEIntMap a -> NonEmpty Int
NEM.keys (NEIntMap Char -> NonEmpty Int)
-> Maybe (NEIntMap Char) -> Maybe (NonEmpty Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NEIntMap 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 a => 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 a => 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
&& (NEIntMap Char -> Int) -> Maybe (NEIntMap Char) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NEIntMap Char -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe (NEIntMap 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) ((NEIntMap Char -> AxisLabels)
-> Maybe (NEIntMap Char) -> Maybe AxisLabels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NEIntMap Char -> AxisLabels
MkAxisLabels Maybe (NEIntMap 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 :: [a] -> Bool
isSorted [a]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> [a] -> [a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [a]
xs ([a] -> [a]
forall a. [a] -> [a]
tail [a]
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.
    IntervalDiagram a -> Interval a
reference      :: Interval a
  , IntervalDiagram a -> Axis
axis           :: Axis
  , IntervalDiagram a -> [IntervalTextLine Int]
intervalValues :: [IntervalTextLine Int]
  , 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 :: 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 a => 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 a => i a -> a
end [IntervalText Int]
x

    prettyLineLabel :: IntervalTextLine Int -> Doc ann
    prettyLineLabel :: 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 :: 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:

>>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings
>>> let mkIntrvl c d b = into @(IntervalText Int) (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 :: 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 :: * -> *) (f :: * -> *) a a (i :: * -> *).
(Functor f, Functor f, Enum a, IntervalSizeable a a,
 Intervallic i a) =>
i a -> f (f a) -> f (f 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 (f :: * -> *) a a (i :: * -> *).
(Functor f, Enum a, IntervalSizeable a a, Intervallic i a) =>
i a -> f a -> f 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 a => 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 (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
before ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
meets ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlaps ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlappedBy ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
metBy ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
-> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
-> ComparativePredicateOf2 (i0 a) (i1 a)
<|> ComparativePredicateOf2 (IntervalText a) (IntervalText a)
forall (i0 :: * -> *) a (i1 :: * -> *).
(Intervallic i0 a, Intervallic i1 a) =>
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 a) =>
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 :: i a -> f a -> f Int
rereference i a
x = (a -> Int) -> f a -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> Int) -> (a -> a) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a b. IntervalSizeable a b => a -> a -> b
`diff` i a -> a
forall (i :: * -> *) a. Intervallic i a => i a -> a
begin i a
x))
  rereferenceL :: i a -> f (f a) -> f (f Int)
rereferenceL i a
x = (f a -> f Int) -> f (f a) -> f (f Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i a -> f a -> f Int
forall (f :: * -> *) a a (i :: * -> *).
(Functor f, Enum a, IntervalSizeable a a, Intervallic i a) =>
i a -> f a -> f Int
rereference i a
x)

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

>>> import Data.Maybe (fromMaybe)
>>> import IntervalAlgebra.IntervalUtilities (gapsWithin)
>>> 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 a, Enum b)
  => i a -- ^ The axis interval
  -> [i a] -- ^ List of intervals to be printed one per line
  -> Either IntervalDiagramParseError (IntervalDiagram a)
simpleIntervalDiagram :: 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
MkIntervalText Char
'=' (i a -> Interval a
forall (i :: * -> *) a. Intervallic i a => 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
MkIntervalText 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 a => i a -> Interval a
getInterval i a
x, [])) [i a]
ivs)