{-| Option specifications using continuations with a changing answer type.

Based on

@<www.is.ocha.ac.jp/~asai/papers/tr08-2.pdf>@

with additional inspiration provided by

@<http://okmij.org/ftp/typed-formatting/FPrintScan.html#DSL-FIn>@

which shows how the same format specifiers can be used for both @sprintf@ and
@sscanf@.

The 'OptSpec' type corresponds to the format specifiers for the sprintf and
sscanf functions, which I called 'ounparse' and 'oparse' here; they no
longer work on 'String's but instead on any list (the intention is, of
course, that this is a list of flags).

As explained in the original paper by Kenichi Asai, we cannot use
'Control.Monad.Trans.Cont.Cont', even with the recent additions of the
@shift@ and @reset@ combinators, since 'Control.Monad.Trans.Cont.Cont'
requires that the answer type remains the same over the whole computation,
while the trick used here requires that the answer type can change.

Besides parsing and unparsing, the 'OptSpec' type contains two more members:
'odesc' is the list of 'OptDescr' that 'System.Console.GetOpt.getOpt' needs
as input for parsing the command line and for generating the usage help,
while 'ocheck' takes a list of flags and returns a list of error messages,
which can be used to check for conflicting options.

-}
module Darcs.UI.Options.Core where

import Darcs.Prelude

import Darcs.UI.Options.Iso

-- * Option specifications

{-| A type for option specifications.

It consists of four components: a parser, an unparser, a checker, and a list
of descriptions.

The parser converts a flag list to some result value. This can never fail:
we demand that primitive parsers are written so that there is always a
default value (use 'Maybe' with default 'Nothing' as a last resort).

The unparser does the opposite of the parser: a value is converted back
to a flag list.

The checker returns a list of error messages (which should be empty if there
are no problems found). This can be used to e.g. check whether there are
conflicting flags in the list.

Separating the checker and parser is unusual. The reason for this is that we
want to support flags coming from multiple sources, such as the command line
or a defaults file. Prioritising these sources is done by concatenating the
flag lists in the order of precedence, so that earlier flags win over later
ones. That means that when parsing the (final) flag list, conflicting flags
are resolved by picking the first flag that matches an option. The checker,
on the other hand, can be called for each source separately.

The last component is a list of descriptors for each single switch/flag that
the option is made of.

The 'OptSpec' type is heavily parameterized. The type arguments are:

[@f@] The flag type, such as 'Darcs.UI.Flags.DarcsFlag'.

[@d@] A type that describes an single flag, such as
  'System.Console.GetOpt.OptDescr' or 'Darcs.UI.Options.DarcsOptDescr'. It
  should be a 'Data.Functor.Functor'.

Abstracting over these types is not technically necessary: for the intended
application in Darcs, we could as well fix them as
@d='Darcs.UI.Options.DarcsOptDescr'@, and @f='Darcs.UI.Flags.DarcsFlag'@,
saving two type parameters. However, doing that here would only obscure
what's going on, making the code harder to understand, not easier. Besides,
the resulting more general type signatures give us additional guarantees,
known as \"free theorems\" (free as in beer, not in speak).

In contrast, the type parameters

[@a@, @b@] are necessary to make chaining of options a la typed printf/scanf
  possible. In a nutshell, @a@ is the result type of a function that
  consumes the result of parsing or unparsing an option, while @b@ is the
  complete type of such a function.

The 'ounparse' and 'oparse' members use continuation passing style, which is
the reason for their apparently \"inverted\" type signature. To understand
them, it helps to look at the type of \"primitive\" (not yet combined)
options (see 'PrimOptSpec' below). For a primitive option, @b@ gets
instantiated to @v -> a@, where @v@ is the type of values associated with
the option. The whole option spec then has type

>  o :: 'OptSpec' d f a (v -> a)

so that the 'oparse' and 'ounparse' members are instantiated to

>  ounparse :: forall a. ([f] -> a) -> (x -> a)
>  oparse   :: forall a. (x -> a) -> ([f] -> a)

which can be easily seen to be equivalent to

>  ounparse :: x -> [f]
>  oparse   :: [f] -> x

Chaining such options results in a combined option of type

>  o1 ^ o2 ^ ... :: OptSpec d f a (v1 -> v2 -> ... -> a)

that is, @b@ gets instantiated to

>  v1 -> v2 -> ... -> a

To use such an option (primitive or combined), you pass in the consumer. A
typical consumer of option values is a command implementation. Given

>  cmd :: v1 -> v2 -> ... -> [String] -> IO ()

we can parse the flags and pass the results to @cmd@:

>  oparse (o1 ^ o2 ^ ...) cmd flags

-}
data OptSpec d f a b = OptSpec
  { OptSpec d f a b -> ([f] -> a) -> b
ounparse :: ([f] -> a) -> b
    -- ^ Convert option value (back) to flag list, in CPS.
  , OptSpec d f a b -> b -> [f] -> a
oparse :: b -> ([f] -> a)
    -- ^ Convert flag list to option value, in CPS. Note: as a pure
    -- function, it is not supposed to fail.
  , OptSpec d f a b -> [f] -> [String]
ocheck :: [f] -> [String]
    -- ^ Check for erros in a flag list, returns error messages.
  , OptSpec d f a b -> [d f]
odesc :: [d f]
    -- ^ Descriptions, one for each flag that makes up the option.
  }

-- ** Primitive combinators

{- $category

The type @'OptSpec' d f@, together with the operation '^' and the unit
'oid' forms a category. We could express this with an

@
  instance 'Control.Category.Category' ('OptSpec' d f) where
    'Control.Category.id' = 'oid'
    ('Control.Category..') = ('^')
@

I decided against doing that because I like the 'id' and '.' from the
"Prelude".

Proving the category laws is easy because the operation and unit are
implemented independently for each component. This means @'OptSpec' d f@
is simply the product of four categories, reducing the problem to proving
the laws for each component separately.

['odesc'] This is just list concatenation, which is a monoid, and every
  monoid is a category (by adding two phantom type arguments).

['ocheck'] Same here, noting that @([f] ->)@ is a monoid homomorphism
  (as expressed by the @instance 'Monoid' b => 'Monoid' (a -> b)@ in
  "Data.Monoid").

['oparse'] This can be seen by flipping the arguments (which is a functor
  i.e. preserves category laws), so the type becomes @[f] -> b -> a@, and
  noting as before that @([f] ->)@ is a monoid homomorphism and thus a
  functor (by adding two phantom type arguments), reducing the operation to
  simple function composition. If this rather abstract argument doesn't
  convince you, do the calculations as an exercise.

['ounparse'] for this I don't have an easy abstract argument at hand,
  so I'll do the calculation:

@
    o1 ^ (o2 ^ o3)
  =   definition outer (^)
    \k -> o1 (\f1 -> (o2 ^ o3) (\f23 -> k (f1 ++ f23)))
  =   definition inner (^)
    \k -> o1 (\f1 -> (\k' -> o2 (\f2 -> o3 (\f3 -> k' (f2 ++ f3)))) (\f23 -> k (f1 ++ f23)))
  =   beta reduce: f1 --> \f23 -> k (f1 ++ f23)
    \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (\f23 -> k (f1 ++ f23)) (f2 ++ f3)))))
  =   beta reduce: f23 --> f2 ++ f3
    \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (k (f1 ++ (f2 ++ f3)))))))
@

and from the other side:

@
    (o1 ^ o2) ^ o3
  =   definition outer (^)
    \k -> (o1 ^ o2) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))
  =   definition inner (^)
    \k -> (\k' -> o1 (\f1 -> o2 (\f2 -> k' (f1 ++ f2)))) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))
  =   beta reduce: k' --> \f12 -> o3 (\f3 -> k (f12 ++ f3))
    \k -> (o1 (\f1 -> o2 (\f2 -> (\f12 -> o3 (\f3 -> k (f12 ++ f3))) (f1 ++ f2))))
  =   beta reduce: f12 --> f1 ++ f2
    \k -> (o1 (\f1 -> o2 (\f2 -> (o3 (\f3 -> k ((f1 ++ f2) ++ f3))))))
@

so again we have reduced the problem to the associativity of @('++')@. Left
and right unit laws are left to the reader...

-}

-- | Identity 'OptSpec', unit for '^'
oid :: OptSpec d f a a
oid :: OptSpec d f a a
oid = OptSpec :: forall (d :: * -> *) f a b.
(([f] -> a) -> b)
-> (b -> [f] -> a) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
OptSpec {[d f]
a -> [f] -> a
[f] -> [String]
([f] -> a) -> a
forall a. [a]
forall p a. p -> [a]
forall p p. p -> p -> p
forall a t. ([a] -> t) -> t
odesc :: forall a. [a]
ocheck :: forall p a. p -> [a]
oparse :: forall p p. p -> p -> p
ounparse :: forall a t. ([a] -> t) -> t
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: a -> [f] -> a
ounparse :: ([f] -> a) -> a
..} where
  ounparse :: ([a] -> t) -> t
ounparse [a] -> t
k = [a] -> t
k []
  oparse :: p -> p -> p
oparse p
k p
_ = p
k
  ocheck :: p -> [a]
ocheck p
_ = []
  odesc :: [a]
odesc = []

-- | 'OptSpec' composition, associative
(^) :: OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
OptSpec ([f] -> b) -> c
ou1 c -> [f] -> b
op1 [f] -> [String]
oc1 [d f]
od1 ^ :: OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec ([f] -> a) -> b
ou2 b -> [f] -> a
op2 [f] -> [String]
oc2 [d f]
od2 = OptSpec :: forall (d :: * -> *) f a b.
(([f] -> a) -> b)
-> (b -> [f] -> a) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
OptSpec {[d f]
c -> [f] -> a
[f] -> [String]
([f] -> a) -> c
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: c -> [f] -> a
ounparse :: ([f] -> a) -> c
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: c -> [f] -> a
ounparse :: ([f] -> a) -> c
..} where
  ounparse :: ([f] -> a) -> c
ounparse [f] -> a
k = ([f] -> b) -> c
ou1 (\[f]
fs1 -> ([f] -> a) -> b
ou2 (\[f]
fs2 -> [f] -> a
k ([f]
fs1 [f] -> [f] -> [f]
forall a. [a] -> [a] -> [a]
++ [f]
fs2)))
  oparse :: c -> [f] -> a
oparse c
k [f]
fs = b -> [f] -> a
op2 (c -> [f] -> b
op1 c
k [f]
fs) [f]
fs
  ocheck :: [f] -> [String]
ocheck [f]
fs = [f] -> [String]
oc1 [f]
fs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [f] -> [String]
oc2 [f]
fs
  odesc :: [d f]
odesc = [d f]
od1 [d f] -> [d f] -> [d f]
forall a. [a] -> [a] -> [a]
++ [d f]
od2

-- ** Derived combinators

-- | Normalise a flag list by parsing and then unparsing it. This adds all
-- implicit (default) flags to the list.
--
-- prop> onormalise opts = (oparse opts . ounparse opts) id
onormalise :: OptSpec d f [f] b -> [f] -> [f]
onormalise :: OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec d f [f] b
opts = (OptSpec d f [f] b -> b -> [f] -> [f]
forall (d :: * -> *) f a b. OptSpec d f a b -> b -> [f] -> a
oparse OptSpec d f [f] b
opts (b -> [f] -> [f])
-> (([f] -> [f]) -> b) -> ([f] -> [f]) -> [f] -> [f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptSpec d f [f] b -> ([f] -> [f]) -> b
forall (d :: * -> *) f a b. OptSpec d f a b -> ([f] -> a) -> b
ounparse OptSpec d f [f] b
opts) [f] -> [f]
forall a. a -> a
id

-- | The list of default flags for an 'OptSpec'.
--
-- prop> defaultFlags opts = onormalise opts []
defaultFlags :: OptSpec d f [f] b -> [f]
defaultFlags :: OptSpec d f [f] b -> [f]
defaultFlags OptSpec d f [f] b
opts = OptSpec d f [f] b -> [f] -> [f]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec d f [f] b
opts []

-- ** Lifting isomorphisms

-- | Lift an isomorphism between @b@ and @c@ to one between
-- @'OptSpec' d f a b@ and @'OptSpec' d f a c@.
--
-- The forward component of the 'Iso' is needed for 'ounparse', the backward
-- component for 'oparse'. For the other two components this is the identity.
oimap :: Iso b c -> OptSpec d f a b -> OptSpec d f a c
oimap :: Iso b c -> OptSpec d f a b -> OptSpec d f a c
oimap (Iso b -> c
fw c -> b
bw) (OptSpec ([f] -> a) -> b
ou b -> [f] -> a
op [f] -> [String]
oc [d f]
od) = OptSpec :: forall (d :: * -> *) f a b.
(([f] -> a) -> b)
-> (b -> [f] -> a) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
OptSpec {[d f]
c -> [f] -> a
[f] -> [String]
([f] -> a) -> c
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: c -> [f] -> a
ounparse :: ([f] -> a) -> c
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: c -> [f] -> a
ounparse :: ([f] -> a) -> c
..} where
  ounparse :: ([f] -> a) -> c
ounparse [f] -> a
k = b -> c
fw (([f] -> a) -> b
ou [f] -> a
k)
  oparse :: c -> [f] -> a
oparse c
k = b -> [f] -> a
op (c -> b
bw c
k)
  ocheck :: [f] -> [String]
ocheck = [f] -> [String]
oc
  odesc :: [d f]
odesc = [d f]
od

instance IsoFunctor (OptSpec d f a) where
  imap :: Iso a b -> OptSpec d f a a -> OptSpec d f a b
imap = Iso a b -> OptSpec d f a a -> OptSpec d f a b
forall b c (d :: * -> *) f a.
Iso b c -> OptSpec d f a b -> OptSpec d f a c
oimap

-- * Primitive options

-- | Type of primitive (not yet combined) options. The type parameter @b@
-- gets instantiated to @(v -> a)@, adding one argument of type @v@
-- to the answer type of the continuation.
type PrimOptSpec d f a v = OptSpec d f a (v -> a)

-- | Combine two list valued options of the same type \"in parellel\". This
-- is done by concatenating the resulting option values ('oparse'), flags
-- ('ounparse'), errors ('ocheck'), and descriptors ('odesc'),
-- respectively, of the input options.
oappend :: PrimOptSpec d f a [v] -> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
OptSpec ([f] -> a) -> [v] -> a
ou1 ([v] -> a) -> [f] -> a
op1 [f] -> [String]
oc1 [d f]
od1 oappend :: PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
`oappend` OptSpec ([f] -> a) -> [v] -> a
ou2 ([v] -> a) -> [f] -> a
op2 [f] -> [String]
oc2 [d f]
od2 = OptSpec :: forall (d :: * -> *) f a b.
(([f] -> a) -> b)
-> (b -> [f] -> a) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
OptSpec {[d f]
[f] -> [String]
([f] -> a) -> [v] -> a
([v] -> a) -> [f] -> a
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: ([v] -> a) -> [f] -> a
ounparse :: ([f] -> a) -> [v] -> a
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: ([v] -> a) -> [f] -> a
ounparse :: ([f] -> a) -> [v] -> a
..} where
  ounparse :: ([f] -> a) -> [v] -> a
ounparse [f] -> a
k [v]
bs = ([f] -> a) -> [v] -> a
ou1 (\[f]
fs1 -> ([f] -> a) -> [v] -> a
ou2 (\[f]
fs2 -> [f] -> a
k ([f]
fs1 [f] -> [f] -> [f]
forall a. [a] -> [a] -> [a]
++ [f]
fs2)) [v]
bs) [v]
bs
  oparse :: ([v] -> a) -> [f] -> a
oparse [v] -> a
k [f]
fs = ([v] -> a) -> [f] -> a
op2 (\[v]
bs2 -> ([v] -> a) -> [f] -> a
op1 (\[v]
bs1 -> [v] -> a
k ([v]
bs1 [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
++ [v]
bs2)) [f]
fs) [f]
fs
  ocheck :: [f] -> [String]
ocheck [f]
fs = [f] -> [String]
oc1 [f]
fs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [f] -> [String]
oc2 [f]
fs
  odesc :: [d f]
odesc = [d f]
od1 [d f] -> [d f] -> [d f]
forall a. [a] -> [a] -> [a]
++ [d f]
od2

-- | Unit for 'oappend'.
oempty :: PrimOptSpec d f a [v]
oempty :: PrimOptSpec d f a [v]
oempty = OptSpec :: forall (d :: * -> *) f a b.
(([f] -> a) -> b)
-> (b -> [f] -> a) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
OptSpec {[d f]
[f] -> [String]
([f] -> a) -> [v] -> a
([v] -> a) -> [f] -> a
forall a. [a]
forall p a. p -> [a]
forall a t p. ([a] -> t) -> p -> t
odesc :: forall a. [a]
ocheck :: forall p a. p -> [a]
oparse :: forall a t p. ([a] -> t) -> p -> t
ounparse :: forall a t p. ([a] -> t) -> p -> t
odesc :: [d f]
ocheck :: [f] -> [String]
oparse :: ([v] -> a) -> [f] -> a
ounparse :: ([f] -> a) -> [v] -> a
..} where
  ounparse :: ([a] -> t) -> p -> t
ounparse [a] -> t
k p
_ = [a] -> t
k []
  oparse :: ([a] -> t) -> p -> t
oparse [a] -> t
k p
_ = [a] -> t
k []
  ocheck :: p -> [a]
ocheck p
_ = []
  odesc :: [a]
odesc = []

instance Semigroup (PrimOptSpec d f a [v]) where
  <> :: PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
(<>) = PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
forall (d :: * -> *) f a v.
PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
oappend

-- | See 'oappend' and 'oempty'.
instance Monoid (PrimOptSpec d f a [v]) where
  mappend :: PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
mappend = PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
forall (d :: * -> *) f a v.
PrimOptSpec d f a [v]
-> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
oappend
  mempty :: PrimOptSpec d f a [v]
mempty = PrimOptSpec d f a [v]
forall (d :: * -> *) f a v. PrimOptSpec d f a [v]
oempty

-- | Parse a list of flags against a primitive option spec, returning the
-- value associated with the option. As noted above, this cannot fail because
-- options always have a default value.
--
-- prop> parseFlags o fs = oparse o id fs
parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec d f a v
o [f]
fs = OptSpec d f v (v -> v) -> (v -> v) -> [f] -> v
forall (d :: * -> *) f a b. OptSpec d f a b -> b -> [f] -> a
oparse OptSpec d f v (v -> v)
forall a. PrimOptSpec d f a v
o v -> v
forall a. a -> a
id [f]
fs

-- | Unparse a primitive option spec and append it to a list of flags.
unparseOpt :: (forall a. PrimOptSpec d f a v) -> v -> [f] -> [f]
unparseOpt :: (forall a. PrimOptSpec d f a v) -> v -> [f] -> [f]
unparseOpt forall a. PrimOptSpec d f a v
o v
v [f]
fs = OptSpec d f [f] (v -> [f]) -> ([f] -> [f]) -> v -> [f]
forall (d :: * -> *) f a b. OptSpec d f a b -> ([f] -> a) -> b
ounparse OptSpec d f [f] (v -> [f])
forall a. PrimOptSpec d f a v
o (\[f]
xfs -> [f]
fs [f] -> [f] -> [f]
forall a. [a] -> [a] -> [a]
++ [f]
xfs) v
v

-- no associativity, higher precedence than comparisons operators (4)
-- and lower than arithemic operators (6,7,8)
infix 5 ?

-- | Operator version of 'parseFlags'
--
-- prop> opt ? flags = parseFlags opt flags
(?) :: (forall a. PrimOptSpec d f a v) -> [f] -> v
? :: (forall a. PrimOptSpec d f a v) -> [f] -> v
(?) = (forall a. PrimOptSpec d f a v) -> [f] -> v
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags