{-# 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
  , interval

    -- * 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           (WatchConfig (..), defaultConfig,
                                            eventTime, watchDir,
                                            withManagerConf)
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 -> FilePath
_output :: FilePath  -- ^ Output file path, format is typically chosen by extension.
  }
  deriving (Int -> DiagramOpts -> ShowS
[DiagramOpts] -> ShowS
DiagramOpts -> FilePath
(Int -> DiagramOpts -> ShowS)
-> (DiagramOpts -> FilePath)
-> ([DiagramOpts] -> ShowS)
-> Show DiagramOpts
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DiagramOpts] -> ShowS
$cshowList :: [DiagramOpts] -> ShowS
show :: DiagramOpts -> FilePath
$cshow :: DiagramOpts -> FilePath
showsPrec :: Int -> DiagramOpts -> ShowS
$cshowsPrec :: Int -> DiagramOpts -> ShowS
Show, Typeable DiagramOpts
DataType
Constr
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 -> DataType
DiagramOpts -> Constr
(forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDiagramOpts :: Constr
$tDiagramOpts :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DiagramOpts -> m DiagramOpts
gmapQi :: Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
gmapQ :: (forall d. Data d => d -> u) -> DiagramOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramOpts -> r
gmapT :: (forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
$cgmapT :: (forall b. Data b => b -> b) -> DiagramOpts -> DiagramOpts
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramOpts)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DiagramOpts)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramOpts)
dataTypeOf :: DiagramOpts -> DataType
$cdataTypeOf :: DiagramOpts -> DataType
toConstr :: DiagramOpts -> Constr
$ctoConstr :: DiagramOpts -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramOpts
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramOpts -> c DiagramOpts
$cp1Data :: Typeable DiagramOpts
Data, Typeable)

makeLenses ''DiagramOpts

-- | Extra options for a program that can offer a choice
--   between multiple diagrams.
data DiagramMultiOpts = DiagramMultiOpts
  { DiagramMultiOpts -> Maybe FilePath
_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 -> FilePath
(Int -> DiagramMultiOpts -> ShowS)
-> (DiagramMultiOpts -> FilePath)
-> ([DiagramMultiOpts] -> ShowS)
-> Show DiagramMultiOpts
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DiagramMultiOpts] -> ShowS
$cshowList :: [DiagramMultiOpts] -> ShowS
show :: DiagramMultiOpts -> FilePath
$cshow :: DiagramMultiOpts -> FilePath
showsPrec :: Int -> DiagramMultiOpts -> ShowS
$cshowsPrec :: Int -> DiagramMultiOpts -> ShowS
Show, Typeable DiagramMultiOpts
DataType
Constr
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 -> DataType
DiagramMultiOpts -> Constr
(forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDiagramMultiOpts :: Constr
$tDiagramMultiOpts :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramMultiOpts -> m DiagramMultiOpts
gmapQi :: Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
gmapQ :: (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramMultiOpts -> r
gmapT :: (forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
$cgmapT :: (forall b. Data b => b -> b)
-> DiagramMultiOpts -> DiagramMultiOpts
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramMultiOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramMultiOpts)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramMultiOpts)
dataTypeOf :: DiagramMultiOpts -> DataType
$cdataTypeOf :: DiagramMultiOpts -> DataType
toConstr :: DiagramMultiOpts -> Constr
$ctoConstr :: DiagramMultiOpts -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramMultiOpts
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramMultiOpts -> c DiagramMultiOpts
$cp1Data :: Typeable 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 -> FilePath
(Int -> DiagramAnimOpts -> ShowS)
-> (DiagramAnimOpts -> FilePath)
-> ([DiagramAnimOpts] -> ShowS)
-> Show DiagramAnimOpts
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DiagramAnimOpts] -> ShowS
$cshowList :: [DiagramAnimOpts] -> ShowS
show :: DiagramAnimOpts -> FilePath
$cshow :: DiagramAnimOpts -> FilePath
showsPrec :: Int -> DiagramAnimOpts -> ShowS
$cshowsPrec :: Int -> DiagramAnimOpts -> ShowS
Show, Typeable DiagramAnimOpts
DataType
Constr
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 -> DataType
DiagramAnimOpts -> Constr
(forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDiagramAnimOpts :: Constr
$tDiagramAnimOpts :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> DiagramAnimOpts -> m DiagramAnimOpts
gmapQi :: Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
gmapQ :: (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DiagramAnimOpts -> r
gmapT :: (forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
$cgmapT :: (forall b. Data b => b -> b) -> DiagramAnimOpts -> DiagramAnimOpts
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramAnimOpts)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DiagramAnimOpts)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DiagramAnimOpts)
dataTypeOf :: DiagramAnimOpts -> DataType
$cdataTypeOf :: DiagramAnimOpts -> DataType
toConstr :: DiagramAnimOpts -> Constr
$ctoConstr :: DiagramAnimOpts -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DiagramAnimOpts
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DiagramAnimOpts -> c DiagramAnimOpts
$cp1Data :: Typeable 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 FilePath
_src      :: Maybe FilePath  -- ^ File path for the source file to recompile.
  , DiagramLoopOpts -> Int
_interval :: Int             -- ^ Interval in seconds at which to check for recompilation.
  }

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 -> FilePath -> DiagramOpts
DiagramOpts
  (Maybe Int -> Maybe Int -> FilePath -> DiagramOpts)
-> Parser (Maybe Int)
-> Parser (Maybe Int -> FilePath -> 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)
      ( FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"WIDTH"
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Desired WIDTH of the output image")
  Parser (Maybe Int -> FilePath -> DiagramOpts)
-> Parser (Maybe Int) -> Parser (FilePath -> DiagramOpts)
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)
      ( FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"HEIGHT"
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Desired HEIGHT of the output image")
  Parser (FilePath -> DiagramOpts)
-> Parser FilePath -> Parser DiagramOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"output" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'o'
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
""
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"OUTPUT"
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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 FilePath -> Bool -> DiagramMultiOpts
DiagramMultiOpts
  (Maybe FilePath -> Bool -> DiagramMultiOpts)
-> Parser (Maybe FilePath) -> Parser (Bool -> DiagramMultiOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser FilePath -> Parser (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser FilePath -> Parser (Maybe FilePath))
-> (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath
-> Parser (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"selection" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'S'
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME"
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"NAME of the diagram to render")
  Parser (Bool -> DiagramMultiOpts)
-> Parser Bool -> Parser DiagramMultiOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"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
      ( FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Frames per unit time (for animations)")

-- | CommandLine parser for 'DiagramLoopOpts'
--   Loop is @--loop@ or @-l@.
--   Source is @--src@ or @-s@.
--   Interval is @-i@ defaulting to one second.
diagramLoopOpts :: Parser DiagramLoopOpts
diagramLoopOpts :: Parser DiagramLoopOpts
diagramLoopOpts = Bool -> Maybe FilePath -> Int -> DiagramLoopOpts
DiagramLoopOpts
  (Bool -> Maybe FilePath -> Int -> DiagramLoopOpts)
-> Parser Bool -> Parser (Maybe FilePath -> Int -> DiagramLoopOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Run in a self-recompiling loop")
  Parser (Maybe FilePath -> Int -> DiagramLoopOpts)
-> Parser (Maybe FilePath) -> Parser (Int -> DiagramLoopOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser FilePath -> Parser (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser FilePath -> Parser (Maybe FilePath))
-> (Mod OptionFields FilePath -> Parser FilePath)
-> Mod OptionFields FilePath
-> Parser (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"src" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
     Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Source file to watch")
  Parser (Int -> DiagramLoopOpts)
-> Parser Int -> Parser DiagramLoopOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
      ( FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"interval" 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
'i'
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
1
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INTERVAL"
     Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Int
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"When running in a loop, check for changes every INTERVAL seconds.")

-- | 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' :: 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
  [ FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"help"
  , Char -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'?'
  , FilePath -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Show this help text"
  ]
  where
#if MIN_VERSION_optparse_applicative(0,16,0)
    param :: ParseError
param = Maybe FilePath -> ParseError
ShowHelpText Maybe FilePath
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 :: Parser a -> IO a
defaultOpts Parser a
optsParser = do
  FilePath
prog <- IO FilePath
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 (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
<> FilePath -> InfoMod a
forall a. FilePath -> InfoMod a
progDesc FilePath
"Command-line diagram generation."
             InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> FilePath -> InfoMod a
forall a. FilePath -> InfoMod a
header FilePath
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 FilePath
parser = ReadM FilePath -> Mod ArgumentFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM FilePath
forall s. IsString s => ReadM s
str Mod ArgumentFields FilePath
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 (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 FilePath
readerAsk ReadM FilePath
-> (FilePath -> ReadM (AlphaColour Double))
-> ReadM (AlphaColour Double)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ReadM (AlphaColour Double)
forall (m :: * -> *).
(Applicative m, MonadFail m) =>
FilePath -> m (AlphaColour Double)
readHexColor)
      rc :: ReadM (Colour Double)
rc = ReadM FilePath
readerAsk ReadM FilePath
-> (FilePath -> ReadM (Colour Double)) -> ReadM (Colour Double)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ReadM (Colour Double)
forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
FilePath -> 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 (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 FilePath
readerAsk ReadM FilePath
-> (FilePath -> ReadM (AlphaColour Double))
-> ReadM (AlphaColour Double)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ReadM (AlphaColour Double)
forall (m :: * -> *).
(Applicative m, MonadFail m) =>
FilePath -> 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 FilePath
readerAsk ReadM FilePath
-> (FilePath -> ReadM (Colour a)) -> ReadM (Colour a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ReadM (Colour a)
forall (m :: * -> *) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
FilePath -> 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 :: FilePath -> m (AlphaColour Double)
readHexColor FilePath
cs = case FilePath
cs of
  (Char
'0':Char
'x':FilePath
hs) -> FilePath -> m (AlphaColour Double)
handle FilePath
hs
  (Char
'#':FilePath
hs)     -> FilePath -> m (AlphaColour Double)
handle FilePath
hs
  FilePath
hs           -> FilePath -> m (AlphaColour Double)
handle FilePath
hs
  where
    handle :: FilePath -> m (AlphaColour Double)
handle FilePath
hs | FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
hs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&& (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit FilePath
hs
      = case FilePath
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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)
        FilePath
_                 -> FilePath -> m (AlphaColour Double)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m (AlphaColour Double))
-> FilePath -> m (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ FilePath
"could not parse as a colour" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
cs
    handle FilePath
_ = FilePath -> m (AlphaColour Double)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m (AlphaColour Double))
-> FilePath -> m (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ FilePath
"could not parse as a colour: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
cs

    isHexDigit :: Char -> Bool
isHexDigit Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
"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,FilePath
"")] -> b -> f b
forall (m :: * -> *) a. Monad m => a -> m a
return b
h
                [(b, FilePath)]
_        -> FilePath -> f b
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> f b) -> FilePath -> f b
forall a b. (a -> b) -> a -> b
$ FilePath
"could not parse as a hex value" FilePath -> 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 (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 (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 (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 (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 (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 (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 (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 :: [(FilePath, QDiagram b v n Any)]
-> Args [(FilePath, QDiagram b v n Any)]
-> ResultOf [(FilePath, QDiagram b v n Any)]
toResult [(FilePath, QDiagram b v n Any)]
ds Args [(FilePath, QDiagram b v n Any)]
_ = [(FilePath, QDiagram b v n Any)]
ResultOf [(FilePath, 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,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)
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 (opts, 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 (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 :: (MainOpts d, DiagramMultiOpts) -> [(FilePath, d)] -> IO ()
defaultMultiMainRender (MainOpts d
opts,DiagramMultiOpts
multi) [(FilePath, 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 [FilePath] -> IO ()
showDiaList (((FilePath, d) -> FilePath) -> [(FilePath, d)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, d) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, d)]
ds)
    else case DiagramMultiOpts
multiDiagramMultiOpts
-> Getting (Maybe FilePath) DiagramMultiOpts (Maybe FilePath)
-> Maybe FilePath
forall s a. s -> Getting a s a -> a
^.Getting (Maybe FilePath) DiagramMultiOpts (Maybe FilePath)
Lens' DiagramMultiOpts (Maybe FilePath)
selection of
           Maybe FilePath
Nothing  -> FilePath -> IO ()
putStrLn FilePath
"No diagram selected." IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FilePath] -> IO ()
showDiaList (((FilePath, d) -> FilePath) -> [(FilePath, d)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, d) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, d)]
ds)
           Just FilePath
sel -> case FilePath -> [(FilePath, d)] -> Maybe d
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
sel [(FilePath, d)]
ds of
                         Maybe d
Nothing -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Unknown diagram: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
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 :: [FilePath] -> IO ()
showDiaList [FilePath]
ds = do
  FilePath -> IO ()
putStrLn FilePath
"Available diagrams:"
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"  " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
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 :: (opts -> QDiagram b v n Any -> IO ())
-> Lens' opts FilePath
-> (opts, DiagramAnimOpts)
-> Animation b v n
-> IO ()
defaultAnimMainRender opts -> QDiagram b v n Any -> IO ()
renderF Lens' opts FilePath
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 = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int)
-> ([QDiagram b v n Any] -> FilePath)
-> [QDiagram b v n Any]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath)
-> ([QDiagram b v n Any] -> Int)
-> [QDiagram b v n Any]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [QDiagram b v n Any] -> 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 FilePath -> Int -> Integer -> opts -> opts
forall s. Lens' s FilePath -> Int -> Integer -> s -> s
indexize Lens' opts FilePath
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 :: Lens' s FilePath -> Int -> Integer -> s -> s
indexize Lens' s FilePath
out Int
nDigits Integer
i s
opts = s
opts s -> (s -> s) -> s
forall a b. a -> (a -> b) -> b
& (FilePath -> Identity FilePath) -> s -> Identity s
Lens' s FilePath
out ((FilePath -> Identity FilePath) -> s -> Identity s)
-> FilePath -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FilePath
output'
  where fmt :: FilePath
fmt         = FilePath
"%0" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nDigits FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"d"
        output' :: FilePath
output'     = FilePath -> ShowS
addExtension (FilePath
base FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> Integer -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
fmt Integer
i) FilePath
ext
        (FilePath
base, FilePath
ext) = FilePath -> (FilePath, FilePath)
splitExtension (s
optss -> Getting FilePath s FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^.Getting FilePath s FilePath
Lens' s FilePath
out)

putStrF :: String -> IO ()
putStrF :: FilePath -> IO ()
putStrF FilePath
s = FilePath -> IO ()
putStr FilePath
s IO () -> IO () -> IO ()
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
  FilePath -> IO ()
putStrLn FilePath
"Looping turned on"
  FilePath
prog <- IO FilePath
getProgName
  [FilePath]
args <- IO [FilePath]
getArgs

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

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

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

  -- Polling is only used on Windows
  WatchConfig -> (WatchManager -> IO ()) -> IO ()
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
defaultConfig { confPollInterval :: Int
confPollInterval = DiagramLoopOpts
opts DiagramLoopOpts -> Getting Int DiagramLoopOpts Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int DiagramLoopOpts Int
Lens' DiagramLoopOpts Int
interval } ((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 -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr (ShowS
takeDirectory FilePath
srcPath') ((FilePath -> Bool) -> ActionPredicate
existsEvents (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
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
            FilePath -> IO ()
putStrF (FilePath
"Modified " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Event -> FilePath
timeOfDay Event
ev FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" ... ")
            ExitCode
exitCode <- FilePath -> FilePath -> [FilePath] -> IO ExitCode
recompile FilePath
srcPath' FilePath
newProg [FilePath]
sandboxArgs
            -- Call the new program without the looping option
            FilePath -> [FilePath] -> ExitCode -> IO ()
run FilePath
newProg [FilePath]
args' ExitCode
exitCode
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
lock Bool
False

      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Watching source file " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
srcPath
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Compiling target: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
newProg
      FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Program args: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
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 FilePath
os of
         -- https://ghc.haskell.org/trac/ghc/ticket/7325
        FilePath
"darwin" -> Int
2000000000
        FilePath
_        -> Int
forall a. Bounded a => a
maxBound

recompile :: FilePath -> FilePath -> [String] -> IO ExitCode
recompile :: FilePath -> FilePath -> [FilePath] -> IO ExitCode
recompile FilePath
srcFile FilePath
outFile [FilePath]
args = do
  let ghcArgs :: [FilePath]
ghcArgs = [FilePath
"--make", FilePath
srcFile, FilePath
"-o", FilePath
outFile] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
args
  FilePath -> IO ()
putStrF FilePath
"compiling ... "
  (ExitCode
exit, FilePath
_, FilePath
stderr) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"ghc" [FilePath]
ghcArgs FilePath
""
  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
$ FilePath -> IO ()
putStrLn (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:FilePath
stderr)
  ExitCode -> IO ExitCode
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 :: FilePath -> ShowS
newProgName FilePath
srcFile FilePath
oldName = case FilePath
os of
  FilePath
"mingw32" ->
      if FilePath
oldName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> ShowS
replaceExtension FilePath
srcFile FilePath
"exe"
        then FilePath -> ShowS
replaceExtension FilePath
srcFile FilePath
".1.exe"
        else FilePath -> ShowS
replaceExtension FilePath
srcFile FilePath
"exe"
  FilePath
_ -> ShowS
dropExtension FilePath
srcFile

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