{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagramOpts] -> ShowS
$cshowList :: [DiagramOpts] -> ShowS
show :: DiagramOpts -> String
$cshow :: DiagramOpts -> String
showsPrec :: Int -> DiagramOpts -> ShowS
$cshowsPrec :: Int -> DiagramOpts -> ShowS
Show, Typeable DiagramOpts
DiagramOpts -> DataType
DiagramOpts -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DiagramOpts -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramOpts -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagramMultiOpts] -> ShowS
$cshowList :: [DiagramMultiOpts] -> ShowS
show :: DiagramMultiOpts -> String
$cshow :: DiagramMultiOpts -> String
showsPrec :: Int -> DiagramMultiOpts -> ShowS
$cshowsPrec :: Int -> DiagramMultiOpts -> ShowS
Show, Typeable DiagramMultiOpts
DiagramMultiOpts -> DataType
DiagramMultiOpts -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramMultiOpts -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramMultiOpts -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagramAnimOpts] -> ShowS
$cshowList :: [DiagramAnimOpts] -> ShowS
show :: DiagramAnimOpts -> String
$cshow :: DiagramAnimOpts -> String
showsPrec :: Int -> DiagramAnimOpts -> ShowS
$cshowsPrec :: Int -> DiagramAnimOpts -> ShowS
Show, Typeable DiagramAnimOpts
DiagramAnimOpts -> DataType
DiagramAnimOpts -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> DiagramAnimOpts -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DiagramAnimOpts -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto)
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"width" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'w'
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"WIDTH"
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Desired WIDTH of the output image")
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto)
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"height" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"HEIGHT"
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Desired HEIGHT of the output image")
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"output" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'o'
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
""
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"OUTPUT"
     forall a. Semigroup a => a -> a -> a
<> 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"selection" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'S'
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"NAME of the diagram to render")
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"list" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'L'
     forall a. Semigroup a => a -> a -> a
<> 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fpu" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
     forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Double
30.0
     forall a. Semigroup a => a -> a -> a
<> 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
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"loop" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Run in a self-recompiling loop")
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
      ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"src" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
     forall a. Semigroup a => a -> a -> a
<> 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' = forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
param forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
  [ forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help"
  , forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'?'
  , 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 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 = forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall a. Parser (a -> a)
helper' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
optsParser)
              ( forall a. InfoMod a
fullDesc
             forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
progDesc String
"Command-line diagram generation."
             forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
header String
prog)
  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 = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall a. Read a => ReadM a
auto forall a. Monoid a => a
mempty

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

-- | Parse a string by just accepting the given string.
instance Parseable String where
  parser :: Parser String
parser = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str 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 = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (ReadM (Colour Double)
rc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (Colour Double)
rh) forall a. Monoid a => a
mempty
    where
      rh, rc :: ReadM (Colour Double)
      rh :: ReadM (Colour Double)
rh = forall {b} {d}. (Ord b, Floating b) => (b, b, b, d) -> Colour b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadM String
readerAsk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(Applicative m, MonadFail m) =>
String -> m (AlphaColour Double)
readHexColor)
      rc :: ReadM (Colour Double)
rc = ReadM String
readerAsk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
_) = 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 = forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (forall {a}. (Ord a, Floating a) => ReadM (AlphaColour a)
rc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (AlphaColour Double)
rh) forall a. Monoid a => a
mempty
    where
      rh :: ReadM (AlphaColour Double)
rh = ReadM String
readerAsk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
(Applicative m, MonadFail m) =>
String -> m (AlphaColour Double)
readHexColor
      rc :: ReadM (AlphaColour a)
rc = forall a. Num a => Colour a -> AlphaColour a
opaque forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadM String
readerAsk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hs forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> 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] -> forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
d forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
e Char
f) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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    ] -> forall a. Num a => Colour a -> AlphaColour a
opaque      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
d forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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        ] -> forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
b Char
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
c) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
d Char
d
        [Char
a,Char
b,Char
c          ] -> forall a. Num a => Colour a -> AlphaColour a
opaque      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
a Char
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
b Char
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {f :: * -> *} {b}.
(Fractional b, Eq b, MonadFail f) =>
Char -> Char -> f b
hex Char
c Char
c)
        String
_                 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"could not parse as a colour" forall a. [a] -> [a] -> [a]
++ String
cs
    handle String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"could not parse as a colour: " forall a. [a] -> [a] -> [a]
++ String
cs

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

    hex :: Char -> Char -> f b
hex Char
a Char
b = (forall a. Fractional a => a -> a -> a
/ b
255) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case forall a. (Eq a, Num a) => ReadS a
readHex [Char
a,Char
b] of
                [(b
h,String
"")] -> forall (m :: * -> *) a. Monad m => a -> m a
return b
h
                [(b, String)]
_        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"could not parse as a hex value" 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 = 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 = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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 = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = (,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parseable a => Parser a
parser forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
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]
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)]
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
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall d. ToResult d => d -> Args d -> ResultOf d
toResult Args (IO d)
args 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) = 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
_ = forall a. Parser a -> IO a
defaultOpts 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 <- forall d (proxy :: * -> *).
(Mainable d, Parseable (MainOpts d)) =>
proxy d -> IO (MainOpts d)
mainArgs (forall a. a -> Identity a
Identity d
d)
    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  = forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender MainOpts (ResultOf d)
opts (forall d. ToResult d => d -> Args d -> ResultOf d
toResult a -> d
f (a, Args 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall d. Mainable d => MainOpts d -> d -> IO ()
mainRender 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
multiforall s a. s -> Getting a s a -> a
^.Lens' DiagramMultiOpts Bool
list
    then [String] -> IO ()
showDiaList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, d)]
ds)
    else case DiagramMultiOpts
multiforall s a. s -> Getting a s a -> a
^.Lens' DiagramMultiOpts (Maybe String)
selection of
           Maybe String
Nothing  -> String -> IO ()
putStrLn String
"No diagram selected." forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO ()
showDiaList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, d)]
ds)
           Just String
sel -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sel [(String, d)]
ds of
                         Maybe d
Nothing -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Unknown diagram: " forall a. [a] -> [a] -> [a]
++ String
sel
                         Just d
d  -> 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 forall a b. (a -> b) -> a -> b
$ String
"  " 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  = forall a. Rational -> Active a -> [a]
simulate (forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ DiagramAnimOpts
animOptsforall s a. s -> Getting a s a -> a
^.Iso' DiagramAnimOpts Double
fpu) Animation b v n
anim
      nDigits :: Int
nDigits = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ [QDiagram b v n Any]
frames
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [QDiagram b v n Any]
frames) forall a b. (a -> b) -> a -> b
$ \(Integer
i,QDiagram b v n Any
d) -> opts -> QDiagram b v n Any -> IO ()
renderF (forall s. Lens' s String -> Int -> Integer -> s -> s
indexize 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 forall a b. a -> (a -> b) -> b
& Lens' s String
out forall s t a b. ASetter s t a b -> b -> s -> t
.~ String
output'
  where fmt :: String
fmt         = String
"%0" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
nDigits forall a. [a] -> [a] -> [a]
++ String
"d"
        output' :: String
output'     = String -> ShowS
addExtension (String
base forall a. [a] -> [a] -> [a]
++ forall r. PrintfType r => String -> r
printf String
fmt Integer
i) String
ext
        (String
base, String
ext) = String -> (String, String)
splitExtension (s
optsforall s a. s -> Getting a s a -> a
^.Lens' s String
out)

putStrF :: String -> IO ()
putStrF :: String -> IO ()
putStrF String
s = String -> IO ()
putStr String
s 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiagramLoopOpts
opts forall s a. s -> Getting a s a -> a
^. Lens' DiagramLoopOpts Bool
loop) 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 forall s a. s -> Getting a s a -> a
^. Lens' DiagramLoopOpts (Maybe String)
src of
    Just String
path -> forall (m :: * -> *) a. Monad m => a -> m a
return String
path
    Maybe String
Nothing   -> forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
nosrc) 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"
             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 -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
sb -> do
      String -> IO ()
putStrLn (String
"Using sandbox " forall a. [a] -> [a] -> [a]
++ ShowS
takeDirectory String
sb)
      forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-package-db", String
sb]

  let args' :: [String]
args'       = forall a. Eq a => a -> [a] -> [a]
delete String
"-l" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [a]
delete String
"--loop" 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   = forall a. Int -> [a] -> [a]
take Int
8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
11 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> UTCTime
eventTime

  forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
defaultConfig { confWatchMode :: WatchMode
confWatchMode = WatchMode
WatchModeOS } forall a b. (a -> b) -> a -> b
$
    \WatchManager
mgr -> do
      IORef Bool
lock <- 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 (forall a. Eq a => a -> a -> Bool
== String
srcPath'))
        forall a b. (a -> b) -> a -> b
$ \Event
ev -> do
          Bool
running <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
lock ((,) Bool
True)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
running forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrF (String
"Modified " forall a. [a] -> [a] -> [a]
++ Event -> String
timeOfDay Event
ev 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
            forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
lock Bool
False

      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Watching source file " forall a. [a] -> [a] -> [a]
++ String
srcPath
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Compiling target: " forall a. [a] -> [a] -> [a]
++ String
newProg
      String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Program args: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args'
      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ case String
os of
         -- https://ghc.haskell.org/trac/ghc/ticket/7325
        String
"darwin" -> Int
2000000000
        String
_        -> 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] 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
""
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exit forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (Char
'\n'forall a. a -> [a] -> [a]
:String
stderr)
  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 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 forall a b. (a -> b) -> a -> b
$ String
prog forall a. [a] -> [a] -> [a]
++ String
" failed with exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
r
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdOut) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"stdout:" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
stdOut
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdErr) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"stderr:" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
stdErr
run String
_ [String]
_ ExitCode
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()