{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ConstrainedClassMethods   #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.CmdLine
-- Copyright   :  (c) 2013 Diagrams team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Convenient creation of command-line-driven executables for rendering
-- diagrams.  This module provides a general framework and default
-- behaviors for parsing command-line arguments, records for diagram
-- creation options in various forms, and classes and instances for a
-- unified entry point to command-line-driven diagram creation
-- executables.
--
-- For a tutorial on command-line diagram creation see
-- <https://diagrams.github.io/doc/cmdline.html>.
--
-----------------------------------------------------------------------------

module Diagrams.Backend.CmdLine
  (

    -- * Options

    -- ** Standard options
    DiagramOpts(..)
  , diagramOpts
  , width
  , height
  , output

    -- ** Multi-diagram options
  , DiagramMultiOpts(..)
  , diagramMultiOpts
  , selection
  , list

    -- ** Animation options
  , DiagramAnimOpts(..)
  , diagramAnimOpts
  , fpu

    -- ** Loop options
  , DiagramLoopOpts(..)
  , diagramLoopOpts
  , loop
  , src

    -- * Parsing
  , Parseable(..)
  , readHexColor

    -- * Command-line programs (@Mainable@)
    -- ** Arguments, rendering, and entry point
  , Mainable(..)

    -- ** General currying
  , ToResult(..)

    -- ** helper functions for implementing @mainRender@
  , defaultAnimMainRender
  , defaultMultiMainRender
  , defaultLoopRender
  ) where

import           Control.Lens              (Lens', makeLenses, (&), (.~), (^.))
import           Diagrams.Animation
import           Diagrams.Attributes
import           Diagrams.Core             hiding (output)
import           Diagrams.Util

import           Options.Applicative
import           Options.Applicative.Types (readerAsk)

import           Control.Monad             (forM_, forever, unless, when)

-- MonadFail comes from Prelude in base-4.13 and up
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail        (MonadFail)
#endif

import           Data.Active               hiding (interval)
import           Data.Char                 (isDigit)
import           Data.Colour
import           Data.Colour.Names
import           Data.Colour.SRGB
import           Data.Data
import           Data.Functor.Identity
import           Data.IORef
import           Data.Kind                 (Type)
import           Data.List                 (delete)
import           Data.Maybe                (fromMaybe)
import           Data.Monoid
import           Numeric

import           Control.Concurrent        (threadDelay)
import           System.Directory          (canonicalizePath)
import           System.Environment        (getArgs, getProgName)
import           System.Exit               (ExitCode (..))
import           System.FilePath           (addExtension, dropExtension,
                                            replaceExtension, splitExtension,
                                            takeDirectory, takeFileName, (</>))
import           System.FSNotify           (defaultConfig,
                                            eventTime, watchDir,
                                            withManagerConf, confWatchMode, WatchMode(..))
import           System.FSNotify.Devel     (existsEvents)
import           System.Info               (os)
import           System.IO                 (hFlush, stdout)
import           System.Process            (readProcessWithExitCode)

import           Text.Printf

-- | Standard options most diagrams are likely to have.
data DiagramOpts = DiagramOpts
  { DiagramOpts -> Maybe Int
_width  :: Maybe Int -- ^ Final output width of diagram.
  , DiagramOpts -> Maybe Int
_height :: Maybe Int -- ^ Final output height of diagram.
  , DiagramOpts -> String
_output :: FilePath  -- ^ Output file path, format is typically chosen by extension.
  }
  deriving (Int -> DiagramOpts -> ShowS
[DiagramOpts] -> ShowS
DiagramOpts -> String
(Int -> DiagramOpts -> ShowS)
-> (DiagramOpts -> String)
-> ([DiagramOpts] -> ShowS)
-> Show DiagramOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagramOpts -> ShowS
showsPrec :: Int -> DiagramOpts -> ShowS
$cshow :: DiagramOpts -> String
show :: DiagramOpts -> String
$cshowList :: [DiagramOpts] -> ShowS
showList :: [DiagramOpts] -> ShowS
Show, Typeable DiagramOpts
Typeable DiagramOpts =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DiagramOpts)
-> (DiagramOpts -> Constr)
-> (DiagramOpts -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DiagramOpts))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DiagramOpts))
-> ((forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r)
-> (forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts)
-> Data DiagramOpts
DiagramOpts -> Constr
DiagramOpts -> DataType
(forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramOpts
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramOpts)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramOpts)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramOpts
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramOpts
$ctoConstr :: DiagramOpts -> Constr
toConstr :: DiagramOpts -> Constr
$cdataTypeOf :: DiagramOpts -> DataType
dataTypeOf :: DiagramOpts -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramOpts)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramOpts)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramOpts)
$cgmapT :: (forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
gmapT :: (forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
Data, Typeable)

makeLenses ''DiagramOpts

-- | Extra options for a program that can offer a choice
--   between multiple diagrams.
data DiagramMultiOpts = DiagramMultiOpts
  { DiagramMultiOpts -> Maybe String
_selection :: Maybe String -- ^ Selected diagram to render.
  , DiagramMultiOpts -> Bool
_list      :: Bool         -- ^ Flag to indicate that a list of available diagrams should
                               --   be printed to standard out.
  }
  deriving (Int -> DiagramMultiOpts -> ShowS
[DiagramMultiOpts] -> ShowS
DiagramMultiOpts -> String
(Int -> DiagramMultiOpts -> ShowS)
-> (DiagramMultiOpts -> String)
-> ([DiagramMultiOpts] -> ShowS)
-> Show DiagramMultiOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagramMultiOpts -> ShowS
showsPrec :: Int -> DiagramMultiOpts -> ShowS
$cshow :: DiagramMultiOpts -> String
show :: DiagramMultiOpts -> String
$cshowList :: [DiagramMultiOpts] -> ShowS
showList :: [DiagramMultiOpts] -> ShowS
Show, Typeable DiagramMultiOpts
Typeable DiagramMultiOpts =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts)
-> (DiagramMultiOpts -> Constr)
-> (DiagramMultiOpts -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DiagramMultiOpts))
-> ((forall b. Data b => b -> b)
    -> DiagramMultiOpts -> DiagramMultiOpts)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> DiagramMultiOpts -> m DiagramMultiOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DiagramMultiOpts -> m DiagramMultiOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DiagramMultiOpts -> m DiagramMultiOpts)
-> Data DiagramMultiOpts
DiagramMultiOpts -> Constr
DiagramMultiOpts -> DataType
(forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramMultiOpts)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts
$ctoConstr :: DiagramMultiOpts -> Constr
toConstr :: DiagramMultiOpts -> Constr
$cdataTypeOf :: DiagramMultiOpts -> DataType
dataTypeOf :: DiagramMultiOpts -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramMultiOpts)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramMultiOpts)
$cgmapT :: (forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
gmapT :: (forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
Data, Typeable)

makeLenses ''DiagramMultiOpts

-- | Extra options for animations.
data DiagramAnimOpts = DiagramAnimOpts
  { DiagramAnimOpts -> Double
_fpu :: Double -- ^ Number of frames per unit time to generate for the animation.
  }
  deriving (Int -> DiagramAnimOpts -> ShowS
[DiagramAnimOpts] -> ShowS
DiagramAnimOpts -> String
(Int -> DiagramAnimOpts -> ShowS)
-> (DiagramAnimOpts -> String)
-> ([DiagramAnimOpts] -> ShowS)
-> Show DiagramAnimOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagramAnimOpts -> ShowS
showsPrec :: Int -> DiagramAnimOpts -> ShowS
$cshow :: DiagramAnimOpts -> String
show :: DiagramAnimOpts -> String
$cshowList :: [DiagramAnimOpts] -> ShowS
showList :: [DiagramAnimOpts] -> ShowS
Show, Typeable DiagramAnimOpts
Typeable DiagramAnimOpts =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts)
-> (DiagramAnimOpts -> Constr)
-> (DiagramAnimOpts -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DiagramAnimOpts))
-> ((forall b. Data b => b -> b)
    -> DiagramAnimOpts -> DiagramAnimOpts)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> DiagramAnimOpts -> m DiagramAnimOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DiagramAnimOpts -> m DiagramAnimOpts)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> DiagramAnimOpts -> m DiagramAnimOpts)
-> Data DiagramAnimOpts
DiagramAnimOpts -> Constr
DiagramAnimOpts -> DataType
(forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramAnimOpts)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts
$ctoConstr :: DiagramAnimOpts -> Constr
toConstr :: DiagramAnimOpts -> Constr
$cdataTypeOf :: DiagramAnimOpts -> DataType
dataTypeOf :: DiagramAnimOpts -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramAnimOpts)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramAnimOpts)
$cgmapT :: (forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
gmapT :: (forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
Data, Typeable)

makeLenses ''DiagramAnimOpts

-- | Extra options for command-line looping.
data DiagramLoopOpts = DiagramLoopOpts
  { DiagramLoopOpts -> Bool
_loop     :: Bool            -- ^ Flag to indicate that the program should loop creation.
  , DiagramLoopOpts -> Maybe String
_src      :: Maybe FilePath  -- ^ File path for the source file to recompile.
  }

makeLenses ''DiagramLoopOpts

-- | Command line parser for 'DiagramOpts'.
--   Width is option @--width@ or @-w@.
--   Height is option @--height@ or @-h@ (note we change help to be @-?@ due to this).
--   Output is option @--output@ or @-o@.
diagramOpts :: Parser DiagramOpts
diagramOpts :: Parser DiagramOpts
diagramOpts = Maybe Int -> Maybe Int -> String -> DiagramOpts
DiagramOpts
  (Maybe Int -> Maybe Int -> String -> DiagramOpts)
-> Parser (Maybe Int)
-> Parser (Maybe Int -> String -> DiagramOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Int -> Parser (Maybe Int))
-> (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int
-> Parser (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto)
      ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"width" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'w'
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"WIDTH"
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Desired WIDTH of the output image")
  Parser (Maybe Int -> String -> DiagramOpts)
-> Parser (Maybe Int) -> Parser (String -> DiagramOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Int -> Parser (Maybe Int))
-> (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int
-> Parser (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto)
      ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"height" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"HEIGHT"
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Desired HEIGHT of the output image")
  Parser (String -> DiagramOpts)
-> Parser String -> Parser DiagramOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"output" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'o'
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
""
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"OUTPUT"
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"OUTPUT file")

-- | Command line parser for 'DiagramMultiOpts'.
--   Selection is option @--selection@ or @-S@.
--   List is @--list@ or @-L@.
diagramMultiOpts :: Parser DiagramMultiOpts
diagramMultiOpts :: Parser DiagramMultiOpts
diagramMultiOpts = Maybe String -> Bool -> DiagramMultiOpts
DiagramMultiOpts
  (Maybe String -> Bool -> DiagramMultiOpts)
-> Parser (Maybe String) -> Parser (Bool -> DiagramMultiOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"selection" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'S'
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"NAME of the diagram to render")
  Parser (Bool -> DiagramMultiOpts)
-> Parser Bool -> Parser DiagramMultiOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
      ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"list" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'L'
     Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"List all available diagrams")

-- | Command line parser for 'DiagramAnimOpts'
--   Frames per unit is @--fpu@ or @-f@.
diagramAnimOpts :: Parser DiagramAnimOpts
diagramAnimOpts :: Parser DiagramAnimOpts
diagramAnimOpts = Double -> DiagramAnimOpts
DiagramAnimOpts
  (Double -> DiagramAnimOpts)
-> Parser Double -> Parser DiagramAnimOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Double -> Mod OptionFields Double -> Parser Double
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Double
forall a. Read a => ReadM a
auto
      ( String -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fpu" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
     Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> Double -> Mod OptionFields Double
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Double
30.0
     Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. String -> Mod f a
help String
"Frames per unit time (for animations)")

-- | CommandLine parser for 'DiagramLoopOpts'
--   Loop is @--loop@ or @-l@.
--   Source is @--src@ or @-s@.
diagramLoopOpts :: Parser DiagramLoopOpts
diagramLoopOpts :: Parser DiagramLoopOpts
diagramLoopOpts = Bool -> Maybe String -> DiagramLoopOpts
DiagramLoopOpts
  (Bool -> Maybe String -> DiagramLoopOpts)
-> Parser Bool -> Parser (Maybe String -> DiagramLoopOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"loop" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Run in a self-recompiling loop")
  Parser (Maybe String -> DiagramLoopOpts)
-> Parser (Maybe String) -> Parser DiagramLoopOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"src" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
     Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Source file to watch")

-- | A hidden \"helper\" option which always fails.
--   Taken from Options.Applicative.Extra but without the
--   short option 'h'.  We want the 'h' for Height.
helper' :: Parser (a -> a)
helper' :: forall a. Parser (a -> a)
helper' = ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
param (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields (a -> a)] -> Mod OptionFields (a -> a)
forall a. Monoid a => [a] -> a
mconcat
  [ String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help"
  , Char -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'?'
  , String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show this help text"
  ]
  where
#if MIN_VERSION_optparse_applicative(0,16,0)
    param :: ParseError
param = Maybe String -> ParseError
ShowHelpText Maybe String
forall a. Maybe a
Nothing
#else
    param = ShowHelpText 
#endif

-- | Apply a parser to the command line that includes the standard
--   program description and help behavior.  Results in parsed commands
--   or fails with a help message.
defaultOpts :: Parser a -> IO a
defaultOpts :: forall a. Parser a -> IO a
defaultOpts Parser a
optsParser = do
  String
prog <- IO String
getProgName
  let p :: ParserInfo a
p = Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (a -> a)
forall a. Parser (a -> a)
helper' Parser (a -> a) -> Parser a -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
optsParser)
              ( InfoMod a
forall a. InfoMod a
fullDesc
             InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"Command-line diagram generation."
             InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
header String
prog)
  ParserInfo a -> IO a
forall a. ParserInfo a -> IO a
execParser ParserInfo a
p

-- | Parseable instances give a command line parser for a type.  If a custom
--   parser for a common type is wanted a newtype wrapper could be used to make
--   a new 'Parseable' instance.  Notice that we do /not/ want as many
--   instances as 'Read' because we want to limit ourselves to things that make
--   sense to parse from the command line.
class Parseable a where
  parser :: Parser a

-- The following instance would overlap with the product instance for
-- Parseable.  We can't tell if one wants to parse (a,b) as one argument or a
-- as one argument and b as another.  Since this is the command line we almost
-- certainly want the latter.  So we need to have less Read instances.
--
-- instance Read a => Parseable a where
--    parser = argument auto mempty

-- | Parse 'Int' according to its 'Read' instance.
instance Parseable Int where
  parser :: Parser Int
parser = ReadM Int -> Mod ArgumentFields Int -> Parser Int
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM Int
forall a. Read a => ReadM a
auto Mod ArgumentFields Int
forall a. Monoid a => a
mempty

-- | Parse 'Double' according to its 'Read' instance.
instance Parseable Double where
  parser :: Parser Double
parser = ReadM Double -> Mod ArgumentFields Double -> Parser Double
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM Double
forall a. Read a => ReadM a
auto Mod ArgumentFields Double
forall a. Monoid a => a
mempty

-- | Parse a string by just accepting the given string.
instance Parseable String where
  parser :: Parser String
parser = ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str Mod ArgumentFields String
forall a. Monoid a => a
mempty

-- | Parse 'DiagramOpts' using the 'diagramOpts' parser.
instance Parseable DiagramOpts where
  parser :: Parser DiagramOpts
parser = Parser DiagramOpts
diagramOpts

-- | Parse 'DiagramMultiOpts' using the 'diagramMultiOpts' parser.
instance Parseable DiagramMultiOpts where
  parser :: Parser DiagramMultiOpts
parser = Parser DiagramMultiOpts
diagramMultiOpts

-- | Parse 'DiagramAnimOpts' using the 'diagramAnimOpts' parser.
instance Parseable DiagramAnimOpts where
  parser :: Parser DiagramAnimOpts
parser = Parser DiagramAnimOpts
diagramAnimOpts

-- | Parse 'DiagramLoopOpts' using the 'diagramLoopOpts' parser.
instance Parseable DiagramLoopOpts where
  parser :: Parser DiagramLoopOpts
parser = Parser DiagramLoopOpts
diagramLoopOpts


-- | Parse @'Colour' Double@ as either a named color from "Data.Colour.Names"
--   or a hexadecimal color.
instance Parseable (Colour Double) where
  parser :: Parser (Colour Double)
parser = ReadM (Colour Double)
-> Mod ArgumentFields (Colour Double) -> Parser (Colour Double)
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (ReadM (Colour Double)
rc ReadM (Colour Double)
-> ReadM (Colour Double) -> ReadM (Colour Double)
forall a. ReadM a -> ReadM a -> ReadM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (Colour Double)
rh) Mod ArgumentFields (Colour Double)
forall a. Monoid a => a
mempty
    where
      rh, rc :: ReadM (Colour Double)
      rh :: ReadM (Colour Double)
rh = (Double, Double, Double, Double) -> Colour Double
forall {b} {d}. (Ord b, Floating b) => (b, b, b, d) -> Colour b
f ((Double, Double, Double, Double) -> Colour Double)
-> (AlphaColour Double -> (Double, Double, Double, Double))
-> AlphaColour Double
-> Colour Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlphaColour Double -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA (AlphaColour Double -> Colour Double)
-> ReadM (AlphaColour Double) -> ReadM (Colour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadM String
readerAsk ReadM String
-> (String -> ReadM (AlphaColour Double))
-> ReadM (AlphaColour Double)
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReadM (AlphaColour Double)
forall (m :: * -> *).
(Applicative m, MonadFail m) =>
String -> m (AlphaColour Double)
readHexColor)
      rc :: ReadM (Colour Double)
rc = ReadM String
readerAsk ReadM String
-> (String -> ReadM (Colour Double)) -> ReadM (Colour Double)
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReadM (Colour Double)
forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
String -> m (Colour a)
readColourName
      f :: (b, b, b, d) -> Colour b
f (b
r,b
g,b
b,d
_) = b -> b -> b -> Colour b
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB b
r b
g b
b -- TODO: this seems unfortunate.  Should the alpha
                               -- value be applied to the r g b values?

-- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names"
--   or a hexadecimal color.
instance Parseable (AlphaColour Double) where
  parser :: Parser (AlphaColour Double)
parser = ReadM (AlphaColour Double)
-> Mod ArgumentFields (AlphaColour Double)
-> Parser (AlphaColour Double)
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (ReadM (AlphaColour Double)
forall {a}. (Ord a, Floating a) => ReadM (AlphaColour a)
rc ReadM (AlphaColour Double)
-> ReadM (AlphaColour Double) -> ReadM (AlphaColour Double)
forall a. ReadM a -> ReadM a -> ReadM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (AlphaColour Double)
rh) Mod ArgumentFields (AlphaColour Double)
forall a. Monoid a => a
mempty
    where
      rh :: ReadM (AlphaColour Double)
rh = ReadM String
readerAsk ReadM String
-> (String -> ReadM (AlphaColour Double))
-> ReadM (AlphaColour Double)
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReadM (AlphaColour Double)
forall (m :: * -> *).
(Applicative m, MonadFail m) =>
String -> m (AlphaColour Double)
readHexColor
      rc :: ReadM (AlphaColour a)
rc = Colour a -> AlphaColour a
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour a -> AlphaColour a)
-> ReadM (Colour a) -> ReadM (AlphaColour a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadM String
readerAsk ReadM String -> (String -> ReadM (Colour a)) -> ReadM (Colour a)
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReadM (Colour a)
forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
String -> m (Colour a)
readColourName)

-- Addapted from the Clay.Color module of the clay package

-- | Parses a hexadecimal color.  The string can start with @\"0x\"@ or @\"#\"@
--   or just be a string of hexadecimal values.  If four or three digits are
--   given each digit is repeated to form a full 24 or 32 bit color.  For
--   example, @\"0xfc4\"@ is the same as @\"0xffcc44\"@.  When eight or six
--   digits are given each pair of digits is a color or alpha channel with the
--   order being red, green, blue, alpha.
readHexColor :: (Applicative m, MonadFail m) => String -> m (AlphaColour Double)
readHexColor :: forall (m :: * -> *).
(Applicative m, MonadFail m) =>
String -> m (AlphaColour Double)
readHexColor String
cs = case String
cs of
  (Char
'0':Char
'x':String
hs) -> String -> m (AlphaColour Double)
handle String
hs
  (Char
'#':String
hs)     -> String -> m (AlphaColour Double)
handle String
hs
  String
hs           -> String -> m (AlphaColour Double)
handle String
hs
  where
    handle :: String -> m (AlphaColour Double)
handle String
hs | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit String
hs
      = case String
hs of
        [Char
a,Char
b,Char
c,Char
d,Char
e,Char
f,Char
g,Char
h] -> Colour Double -> Double -> AlphaColour Double
forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (Colour Double -> Double -> AlphaColour Double)
-> m (Colour Double) -> m (Double -> AlphaColour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (Double -> Double -> Double -> Colour Double)
-> m Double -> m (Double -> Double -> Colour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
b m (Double -> Double -> Colour Double)
-> m Double -> m (Double -> Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
d m (Double -> Colour Double) -> m Double -> m (Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
e Char
f) m (Double -> AlphaColour Double)
-> m Double -> m (AlphaColour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
g Char
h
        [Char
a,Char
b,Char
c,Char
d,Char
e,Char
f    ] -> Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque      (Colour Double -> AlphaColour Double)
-> m (Colour Double) -> m (AlphaColour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (Double -> Double -> Double -> Colour Double)
-> m Double -> m (Double -> Double -> Colour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
b m (Double -> Double -> Colour Double)
-> m Double -> m (Double -> Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
d m (Double -> Colour Double) -> m Double -> m (Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
e Char
f)
        [Char
a,Char
b,Char
c,Char
d        ] -> Colour Double -> Double -> AlphaColour Double
forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (Colour Double -> Double -> AlphaColour Double)
-> m (Colour Double) -> m (Double -> AlphaColour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (Double -> Double -> Double -> Colour Double)
-> m Double -> m (Double -> Double -> Colour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
a m (Double -> Double -> Colour Double)
-> m Double -> m (Double -> Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
b Char
b m (Double -> Colour Double) -> m Double -> m (Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
c) m (Double -> AlphaColour Double)
-> m Double -> m (AlphaColour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
d Char
d
        [Char
a,Char
b,Char
c          ] -> Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque      (Colour Double -> AlphaColour Double)
-> m (Colour Double) -> m (AlphaColour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (Double -> Double -> Double -> Colour Double)
-> m Double -> m (Double -> Double -> Colour Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
a m (Double -> Double -> Colour Double)
-> m Double -> m (Double -> Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
b Char
b m (Double -> Colour Double) -> m Double -> m (Colour Double)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Char -> m Double
forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
c)
        String
_                 -> String -> m (AlphaColour Double)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (AlphaColour Double))
-> String -> m (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ String
"could not parse as a colour" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cs
    handle String
_ = String -> m (AlphaColour Double)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (AlphaColour Double))
-> String -> m (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ String
"could not parse as a colour: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cs

    isHexDigit :: Char -> Bool
isHexDigit Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"abcdef"

    hex :: Char -> Char -> f b
hex Char
a Char
b = (b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
255) (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ReadS b
forall a. (Eq a, Num a) => ReadS a
readHex [Char
a,Char
b] of
                [(b
h,String
"")] -> b -> f b
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return b
h
                [(b, String)]
_        -> String -> f b
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f b) -> String -> f b
forall a b. (a -> b) -> a -> b
$ String
"could not parse as a hex value" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
a,Char
b]


-- | This instance is needed to signal the end of a chain of
--   nested tuples, it always just results in the unit value
--   without consuming anything.
instance Parseable () where
  parser :: Parser ()
parser = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Allow 'Parseable' things to be combined.
instance (Parseable a, Parseable b) => Parseable (a,b) where
  parser :: Parser (a, b)
parser = (,) (a -> b -> (a, b)) -> Parser a -> Parser (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
forall a. Parseable a => Parser a
parser Parser (b -> (a, b)) -> Parser b -> Parser (a, b)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser b
forall a. Parseable a => Parser a
parser

-- | Triples of Parsebales should also be Parseable.
instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) where
  parser :: Parser (a, b, c)
parser = (,,) (a -> b -> c -> (a, b, c))
-> Parser a -> Parser (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
forall a. Parseable a => Parser a
parser Parser (b -> c -> (a, b, c)) -> Parser b -> Parser (c -> (a, b, c))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser b
forall a. Parseable a => Parser a
parser Parser (c -> (a, b, c)) -> Parser c -> Parser (a, b, c)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser c
forall a. Parseable a => Parser a
parser

instance (Parseable a, Parseable b, Parseable c, Parseable d) => Parseable (a, b, c, d) where
  parser :: Parser (a, b, c, d)
parser = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Parser a -> Parser (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
forall a. Parseable a => Parser a
parser Parser (b -> c -> d -> (a, b, c, d))
-> Parser b -> Parser (c -> d -> (a, b, c, d))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser b
forall a. Parseable a => Parser a
parser Parser (c -> d -> (a, b, c, d))
-> Parser c -> Parser (d -> (a, b, c, d))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser c
forall a. Parseable a => Parser a
parser Parser (d -> (a, b, c, d)) -> Parser d -> Parser (a, b, c, d)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser d
forall a. Parseable a => Parser a
parser

-- | This class allows us to abstract over functions that take some arguments
--   and produce a final value.  When some @d@ is an instance of
--   'ToResult' we get a type @'Args' d@ that is a type of /all/ the arguments
--   at once, and a type @'ResultOf' d@ that is the type of the final result from
--   some base case instance.
class ToResult d where
  type Args d :: Type
  type ResultOf d :: Type

  toResult :: d -> Args d -> ResultOf d

-- | A diagram can always produce a diagram when given @()@ as an argument.
--   This is our base case.
instance ToResult (QDiagram b v n Any) where
  type Args (QDiagram b v n Any) = ()
  type ResultOf (QDiagram b v n Any) = QDiagram b v n Any

  toResult :: QDiagram b v n Any
-> Args (QDiagram b v n Any) -> ResultOf (QDiagram b v n Any)
toResult QDiagram b v n Any
d Args (QDiagram b v n Any)
_ = QDiagram b v n Any
ResultOf (QDiagram b v n Any)
d

-- | A list of diagrams can produce pages.
instance ToResult [QDiagram b v n Any] where
  type Args [QDiagram b v n Any] = ()
  type ResultOf [QDiagram b v n Any] = [QDiagram b v n Any]

  toResult :: [QDiagram b v n Any]
-> Args [QDiagram b v n Any] -> ResultOf [QDiagram b v n Any]
toResult [QDiagram b v n Any]
ds Args [QDiagram b v n Any]
_ = [QDiagram b v n Any]
ResultOf [QDiagram b v n Any]
ds

-- | A list of named diagrams can give the multi-diagram interface.
instance ToResult [(String, QDiagram b v n Any)] where
  type Args [(String,QDiagram b v n Any)] = ()
  type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)]

  toResult :: [(String, QDiagram b v n Any)]
-> Args [(String, QDiagram b v n Any)]
-> ResultOf [(String, QDiagram b v n Any)]
toResult [(String, QDiagram b v n Any)]
ds Args [(String, QDiagram b v n Any)]
_ = [(String, QDiagram b v n Any)]
ResultOf [(String, QDiagram b v n Any)]
ds

-- | An animation is another suitable base case.
instance ToResult (Animation b v n) where
  type Args (Animation b v n) = ()
  type ResultOf (Animation b v n) = Animation b v n

  toResult :: Animation b v n
-> Args (Animation b v n) -> ResultOf (Animation b v n)
toResult Animation b v n
a Args (Animation b v n)
_ = Animation b v n
ResultOf (Animation b v n)
a

-- | Diagrams that require IO to build are a base case.
instance ToResult d => ToResult (IO d) where
  type Args (IO d) = Args d
  type ResultOf (IO d) = IO (ResultOf d)

  toResult :: IO d -> Args (IO d) -> ResultOf (IO d)
toResult IO d
d Args (IO d)
args = (d -> Args d -> ResultOf d) -> Args d -> d -> ResultOf d
forall a b c. (a -> b -> c) -> b -> a -> c
flip d -> Args d -> ResultOf d
forall d. ToResult d => d -> Args d -> ResultOf d
toResult Args d
Args (IO d)
args (d -> ResultOf d) -> IO d -> IO (ResultOf d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO d
d

-- | An instance for a function that, given some 'a', can produce a 'd' that is
--   also an instance of 'ToResult'.  For this to work we need both the
--   argument 'a' and all the arguments that 'd' will need.  Producing the
--   result is simply applying the argument to the producer and passing the
--   remaining arguments to the produced producer.

--   The previous paragraph stands as a witness to the fact that Haskell code
--   is clearer and easier to understand then paragraphs in English written by
--   me.
instance ToResult d => ToResult (a -> d) where
  type Args (a -> d) = (a, Args d)
  type ResultOf (a -> d) = ResultOf d

  toResult :: (a -> d) -> Args (a -> d) -> ResultOf (a -> d)
toResult a -> d
f (a
a,Args d
args) = d -> Args d -> ResultOf d
forall d. ToResult d => d -> Args d -> ResultOf d
toResult (a -> d
f a
a) Args d
args


-- | This class represents the various ways we want to support diagram creation
--   from the command line.  It has the right instances to select between creating
--   single static diagrams, multiple static diagrams, static animations, and
--   functions that produce diagrams as long as the arguments are 'Parseable'.
--
--   Backends are expected to create @Mainable@ instances for the types that are
--   suitable for generating output in the backend's format.  For instance,
--   Postscript can handle single diagrams, pages of diagrams, animations as
--   separate files, and association lists.  This implies instances for
--   @Diagram Postscript R2@, @[Diagram Postscript R2]@, @Animation Postscript R2@,
--   and @[(String,Diagram Postscript R2)]@.  We can consider these as the base
--   cases for the function instance.
--
--   The associated type 'MainOpts' describes the options which need to be parsed
--   from the command-line and passed to @mainRender@.
class Mainable d where
  -- | Associated type that describes the options which need to be parsed
  -- from the command-line and passed to @mainRender@.
  type MainOpts d :: Type

  -- | This method invokes the command-line parser resulting in an options
  -- value or ending the program with an error or help message.
  -- Typically the default instance will work.  If a different help message
  -- or parsing behavior is desired a new implementation is appropriate.
  mainArgs :: Parseable (MainOpts d) => proxy d -> IO (MainOpts d)
  mainArgs proxy d
_ = Parser (MainOpts d) -> IO (MainOpts d)
forall a. Parser a -> IO a
defaultOpts Parser (MainOpts d)
forall a. Parseable a => Parser a
parser

  -- | Backend specific work of rendering with the given options and mainable
  -- value is done here.  All backend instances should implement this method.
  mainRender :: MainOpts d -> d -> IO ()

  -- | Main entry point for command-line diagram creation.  This is the method
  -- that users will call from their program @main@.  For instance an expected
  -- user program would take the following form.
  --
  -- @
  -- import Diagrams.Prelude
  -- import Diagrams.Backend.TheBestBackend.CmdLine
  --
  -- d :: Diagram B R2
  -- d = ...
  --
  -- main = mainWith d
  -- @
  --
  -- Most backends should be able to use the default implementation.  A different
  -- implementation should be used to handle more complex interactions with the user.
  mainWith :: Parseable (MainOpts d) => d -> IO ()
  mainWith d
d = do
    MainOpts d
opts <- Identity d -> IO (MainOpts d)
forall d (proxy :: * -> *).
(Mainable d, Parseable (MainOpts d)) =>
proxy d -> IO (MainOpts d)
forall (proxy :: * -> *).
Parseable (MainOpts d) =>
proxy d -> IO (MainOpts d)
mainArgs (d -> Identity d
forall a. a -> Identity a
Identity d
d)
    MainOpts d -> d -> IO ()
forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender MainOpts d
opts d
d

-- | This instance allows functions resulting in something that is 'Mainable' to
--   be 'Mainable'.  It takes a parse of collected arguments and applies them to
--   the given function producing the 'Mainable' result.
instance (ToResult d, Mainable (ResultOf d))
        => Mainable (a -> d) where
  type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d))

  mainRender :: MainOpts (a -> d) -> (a -> d) -> IO ()
mainRender (MainOpts (ResultOf d)
opts, (a, Args d)
a) a -> d
f  = MainOpts (ResultOf d) -> ResultOf d -> IO ()
forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender MainOpts (ResultOf d)
opts ((a -> d) -> Args (a -> d) -> ResultOf (a -> d)
forall d. ToResult d => d -> Args d -> ResultOf d
toResult a -> d
f (a, Args d)
Args (a -> d)
a)
-- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ...
--       Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ?

-- | With this instance we can perform IO to produce something
--   'Mainable' before rendering.
instance Mainable d => Mainable (IO d) where
  type MainOpts (IO d) = MainOpts d

  mainRender :: MainOpts (IO d) -> IO d -> IO ()
mainRender MainOpts (IO d)
opts IO d
dio = IO d
dio IO d -> (d -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MainOpts d -> d -> IO ()
forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender MainOpts d
MainOpts (IO d)
opts

-- | @defaultMultiMainRender@ is an implementation of 'mainRender' where
--   instead of a single diagram it takes a list of diagrams paired with names
--   as input.  The generated executable then takes a @--selection@ option
--   specifying the name of the diagram that should be rendered.  The list of
--   available diagrams may also be printed by passing the option @--list@.
--
--   Typically a backend can write its @[(String,QDiagram b v n Any)]@ instance as
--
--   @
--   instance Mainable [(String,QDiagram b v n Any)] where
--       type MainOpts [(String,QDiagram b v n Any)] = (DiagramOpts, DiagramMultiOpts)
--       mainRender = defaultMultiMainRender
--   @
--
--   We do not provide this instance in general so that backends can choose to
--   opt-in to this form or provide a different instance that makes more sense.
defaultMultiMainRender :: Mainable d => (MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO ()
defaultMultiMainRender :: forall d.
Mainable d =>
(MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO ()
defaultMultiMainRender (MainOpts d
opts,DiagramMultiOpts
multi) [(String, d)]
ds =
  if DiagramMultiOpts
multiDiagramMultiOpts -> Getting Bool DiagramMultiOpts Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool DiagramMultiOpts Bool
Lens' DiagramMultiOpts Bool
list
    then [String] -> IO ()
showDiaList (((String, d) -> String) -> [(String, d)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, d) -> String
forall a b. (a, b) -> a
fst [(String, d)]
ds)
    else case DiagramMultiOpts
multiDiagramMultiOpts
-> Getting (Maybe String) DiagramMultiOpts (Maybe String)
-> Maybe String
forall s a. s -> Getting a s a -> a
^.Getting (Maybe String) DiagramMultiOpts (Maybe String)
Lens' DiagramMultiOpts (Maybe String)
selection of
           Maybe String
Nothing  -> String -> IO ()
putStrLn String
"No diagram selected." IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO ()
showDiaList (((String, d) -> String) -> [(String, d)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, d) -> String
forall a b. (a, b) -> a
fst [(String, d)]
ds)
           Just String
sel -> case String -> [(String, d)] -> Maybe d
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sel [(String, d)]
ds of
                         Maybe d
Nothing -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown diagram: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sel
                         Just d
d  -> MainOpts d -> d -> IO ()
forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender MainOpts d
opts d
d

-- | Display the list of diagrams available for rendering.
showDiaList :: [String] -> IO ()
showDiaList :: [String] -> IO ()
showDiaList [String]
ds = do
  String -> IO ()
putStrLn String
"Available diagrams:"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ds

-- | @defaultAnimMainRender@ is an implementation of 'mainRender' which renders
--   an animation as numbered frames, named by extending the given output file
--   name by consecutive integers.  For example if the given output file name is
--   @foo\/blah.ext@, the frames will be saved in @foo\/blah001.ext@,
--   @foo\/blah002.ext@, and so on (the number of padding digits used depends on
--   the total number of frames).  It is up to the user to take these images and
--   stitch them together into an actual animation format (using, /e.g./
--   @ffmpeg@).
--
--   Of course, this is a rather crude method of rendering animations;
--   more sophisticated methods will likely be added in the future.
--
--   The @fpu@ option from 'DiagramAnimOpts' can be used to control how many frames will
--   be output for each second (unit time) of animation.
--
--   This function requires a lens into the structure that the particular backend
--   uses for it's diagram base case.  If @MainOpts (QDiagram b v n Any) ~ DiagramOpts@
--   then this lens will simply be 'output'.  For a backend supporting looping
--   it will most likely be @_1 . output@.  This lens is required because the
--   implementation works by modifying the output field and running the base @mainRender@.
--   Typically a backend can write its @Animation B V@ instance as
--
--   @
--   instance Mainable (Animation B V) where
--       type MainOpts (Animation B V) = (DiagramOpts, DiagramAnimOpts)
--       mainRender = defaultAnimMainRender output
--   @
--
--   We do not provide this instance in general so that backends can choose to
--   opt-in to this form or provide a different instance that makes more sense.

defaultAnimMainRender ::
    (opts -> QDiagram b v n Any -> IO ())
    -> Lens' opts FilePath -- ^ A lens into the output path.
    -> (opts, DiagramAnimOpts)
    -> Animation b v n
    -> IO ()
defaultAnimMainRender :: forall opts b (v :: * -> *) n.
(opts -> QDiagram b v n Any -> IO ())
-> Lens' opts String
-> (opts, DiagramAnimOpts)
-> Animation b v n
-> IO ()
defaultAnimMainRender opts -> QDiagram b v n Any -> IO ()
renderF Lens' opts String
out (opts
opts,DiagramAnimOpts
animOpts) Animation b v n
anim = do
  let frames :: [QDiagram b v n Any]
frames  = Rational -> Animation b v n -> [QDiagram b v n Any]
forall a. Rational -> Active a -> [a]
simulate (Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Rational) -> Double -> Rational
forall a b. (a -> b) -> a -> b
$ DiagramAnimOpts
animOptsDiagramAnimOpts -> Getting Double DiagramAnimOpts Double -> Double
forall s a. s -> Getting a s a -> a
^.Getting Double DiagramAnimOpts Double
Iso' DiagramAnimOpts Double
fpu) Animation b v n
anim
      nDigits :: Int
nDigits = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ([QDiagram b v n Any] -> String) -> [QDiagram b v n Any] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ([QDiagram b v n Any] -> Int) -> [QDiagram b v n Any] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [QDiagram b v n Any] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([QDiagram b v n Any] -> Int) -> [QDiagram b v n Any] -> Int
forall a b. (a -> b) -> a -> b
$ [QDiagram b v n Any]
frames
  [(Integer, QDiagram b v n Any)]
-> ((Integer, QDiagram b v n Any) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Integer]
-> [QDiagram b v n Any] -> [(Integer, QDiagram b v n Any)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [QDiagram b v n Any]
frames) (((Integer, QDiagram b v n Any) -> IO ()) -> IO ())
-> ((Integer, QDiagram b v n Any) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
i,QDiagram b v n Any
d) -> opts -> QDiagram b v n Any -> IO ()
renderF (Lens' opts String -> Int -> Integer -> opts -> opts
forall s. Lens' s String -> Int -> Integer -> s -> s
indexize (String -> f String) -> opts -> f opts
Lens' opts String
out Int
nDigits Integer
i opts
opts) QDiagram b v n Any
d

-- | @indexize d n@ adds the integer index @n@ to the end of the
--   output file name, padding with zeros if necessary so that it uses
--   at least @d@ digits.
indexize :: Lens' s FilePath -> Int -> Integer -> s -> s
indexize :: forall s. Lens' s String -> Int -> Integer -> s -> s
indexize Lens' s String
out Int
nDigits Integer
i s
opts = s
opts s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& (String -> Identity String) -> s -> Identity s
Lens' s String
out ((String -> Identity String) -> s -> Identity s)
-> String -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String
output'
  where fmt :: String
fmt         = String
"%0" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nDigits String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"d"
        output' :: String
output'     = String -> ShowS
addExtension (String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
fmt Integer
i) String
ext
        (String
base, String
ext) = String -> (String, String)
splitExtension (s
optss -> Getting String s String -> String
forall s a. s -> Getting a s a -> a
^.Getting String s String
Lens' s String
out)

putStrF :: String -> IO ()
putStrF :: String -> IO ()
putStrF String
s = String -> IO ()
putStr String
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

defaultLoopRender :: DiagramLoopOpts -> IO ()
defaultLoopRender :: DiagramLoopOpts -> IO ()
defaultLoopRender DiagramLoopOpts
opts = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiagramLoopOpts
opts DiagramLoopOpts -> Getting Bool DiagramLoopOpts Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool DiagramLoopOpts Bool
Lens' DiagramLoopOpts Bool
loop) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
putStrLn String
"Looping turned on"
  String
prog <- IO String
getProgName
  [String]
args <- IO [String]
getArgs

  String
srcPath <- case DiagramLoopOpts
opts DiagramLoopOpts
-> Getting (Maybe String) DiagramLoopOpts (Maybe String)
-> Maybe String
forall s a. s -> Getting a s a -> a
^. Getting (Maybe String) DiagramLoopOpts (Maybe String)
Lens' DiagramLoopOpts (Maybe String)
src of
    Just String
path -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
    Maybe String
Nothing   -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. HasCallStack => String -> a
error String
nosrc) (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findHsFile String
prog
      where
        nosrc :: String
nosrc = String
"Unable to find Haskell source file.\n"
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Specify source file with '-s' or '--src'"
  String
srcPath' <- String -> IO String
canonicalizePath String
srcPath

  Maybe String
sandbox     <- [String] -> IO (Maybe String)
findSandbox []
  [String]
sandboxArgs <- case Maybe String
sandbox of
    Maybe String
Nothing -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
sb -> do
      String -> IO ()
putStrLn (String
"Using sandbox " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
takeDirectory String
sb)
      [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-package-db", String
sb]

  let args' :: [String]
args'       = String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"-l" ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
delete String
"--loop" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
args
      newProg :: String
newProg     = String -> ShowS
newProgName (ShowS
takeFileName String
srcPath) String
prog
      timeOfDay :: Event -> String
timeOfDay   = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 ShowS -> (Event -> String) -> Event -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
11 ShowS -> (Event -> String) -> Event -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> (Event -> UTCTime) -> Event -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> UTCTime
eventTime

  WatchConfig -> (WatchManager -> IO ()) -> IO ()
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
defaultConfig ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \WatchManager
mgr -> do
      IORef Bool
lock <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

      IO ()
_ <- WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr (ShowS
takeDirectory String
srcPath') ((String -> Bool) -> ActionPredicate
existsEvents (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
srcPath'))
        (Action -> IO (IO ())) -> Action -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Event
ev -> do
          Bool
running <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
lock ((,) Bool
True)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
running (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrF (String
"Modified " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Event -> String
timeOfDay Event
ev String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ... ")
            ExitCode
exitCode <- String -> String -> [String] -> IO ExitCode
recompile String
srcPath' String
newProg [String]
sandboxArgs
            -- Call the new program without the looping option
            String -> [String] -> ExitCode -> IO ()
run String
newProg [String]
args' ExitCode
exitCode
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
lock Bool
False

      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Watching source file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcPath
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Compiling target: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
newProg
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Program args: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args'
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> (Int -> IO ()) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ case String
os of
         -- https://ghc.haskell.org/trac/ghc/ticket/7325
        String
"darwin" -> Int
2000000000
        String
_        -> Int
forall a. Bounded a => a
maxBound

recompile :: FilePath -> FilePath -> [String] -> IO ExitCode
recompile :: String -> String -> [String] -> IO ExitCode
recompile String
srcFile String
outFile [String]
args = do
  let ghcArgs :: [String]
ghcArgs = [String
"--make", String
srcFile, String
"-o", String
outFile] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
  String -> IO ()
putStrF String
"compiling ... "
  (ExitCode
exit, String
_, String
stderr) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"ghc" [String]
ghcArgs String
""
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exit ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
stderr)
  ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exit

-- | On Windows, the next compilation must have a different output
--   than the currently running program.
newProgName :: FilePath -> String -> String
newProgName :: String -> ShowS
newProgName String
srcFile String
oldName = case String
os of
  String
"mingw32" ->
      if String
oldName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ShowS
replaceExtension String
srcFile String
"exe"
        then String -> ShowS
replaceExtension String
srcFile String
".1.exe"
        else String -> ShowS
replaceExtension String
srcFile String
"exe"
  String
_ -> ShowS
dropExtension String
srcFile

-- | Run the given program with specified arguments, if and only if
--   the previous command returned ExitSuccess.
run :: String -> [String] -> ExitCode -> IO ()
run :: String -> [String] -> ExitCode -> IO ()
run String
prog [String]
args ExitCode
ExitSuccess = do
  let path :: String
path = String
"." String -> ShowS
</> String
prog
  String -> IO ()
putStrF String
"running ... "
  (ExitCode
exit, String
stdOut, String
stdErr) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
path [String]
args String
""
  case ExitCode
exit of
    ExitCode
ExitSuccess   -> String -> IO ()
putStrLn String
"done."
    ExitFailure Int
r -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prog String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed with exit code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
r
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdOut) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"stdout:" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
stdOut
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdErr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"stderr:" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
stdErr
run String
_ [String]
_ ExitCode
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()