{-# LANGUAGE FlexibleInstances,
             FunctionalDependencies,
             GeneralizedNewtypeDeriving #-}

-- | A library providing support for templating
module Tophat
  (
   -- * Basic functionality
   Context,
   Template(runTemplate),
   makeTemplate,
   embed,
   embedConst,
   embedShow,
   -- * Control structures
   -- ** for
   ForContext, forH, endfor,
   -- ** if
   IfContext, ifH, endif,
   -- ** process
   ProcessContext, procH, endproc,
   -- ** with
   WithContext, withH, endwith,
   -- * Re-exported code
   (>>>)
  ) where

import Control.Arrow ((>>>))
import Data.Functor.Identity (Identity(..))
import Data.Profunctor (Profunctor, rmap)
import Data.String (IsString, fromString)


-- | A @Template a s@ wraps a function which takes an argument of type
-- @a@, and is intended to return some 'IsString' type @s@.
newtype Template a s = Template { forall a s. Template a s -> a -> s
runTemplate :: a -> s }
  deriving (NonEmpty (Template a s) -> Template a s
Template a s -> Template a s -> Template a s
forall b. Integral b => b -> Template a s -> Template a s
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a s. Semigroup s => NonEmpty (Template a s) -> Template a s
forall a s.
Semigroup s =>
Template a s -> Template a s -> Template a s
forall a s b.
(Semigroup s, Integral b) =>
b -> Template a s -> Template a s
stimes :: forall b. Integral b => b -> Template a s -> Template a s
$cstimes :: forall a s b.
(Semigroup s, Integral b) =>
b -> Template a s -> Template a s
sconcat :: NonEmpty (Template a s) -> Template a s
$csconcat :: forall a s. Semigroup s => NonEmpty (Template a s) -> Template a s
<> :: Template a s -> Template a s -> Template a s
$c<> :: forall a s.
Semigroup s =>
Template a s -> Template a s -> Template a s
Semigroup, Template a s
[Template a s] -> Template a s
Template a s -> Template a s -> Template a s
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a} {s}. Monoid s => Semigroup (Template a s)
forall a s. Monoid s => Template a s
forall a s. Monoid s => [Template a s] -> Template a s
forall a s.
Monoid s =>
Template a s -> Template a s -> Template a s
mconcat :: [Template a s] -> Template a s
$cmconcat :: forall a s. Monoid s => [Template a s] -> Template a s
mappend :: Template a s -> Template a s -> Template a s
$cmappend :: forall a s.
Monoid s =>
Template a s -> Template a s -> Template a s
mempty :: Template a s
$cmempty :: forall a s. Monoid s => Template a s
Monoid, forall a b c. (a -> b) -> Template b c -> Template a c
forall b c a. (b -> c) -> Template a b -> Template a c
forall a b c d.
(a -> b) -> (c -> d) -> Template b c -> Template a d
forall a b c (q :: * -> * -> *).
Coercible b a =>
Template b c -> q a b -> Template a c
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> Template a b -> Template a c
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d)
-> (forall a b c. (a -> b) -> p b c -> p a c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> p a b -> p a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    p b c -> q a b -> p a c)
-> Profunctor p
.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
Template b c -> q a b -> Template a c
$c.# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
Template b c -> q a b -> Template a c
#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> Template a b -> Template a c
$c#. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> Template a b -> Template a c
rmap :: forall b c a. (b -> c) -> Template a b -> Template a c
$crmap :: forall b c a. (b -> c) -> Template a b -> Template a c
lmap :: forall a b c. (a -> b) -> Template b c -> Template a c
$clmap :: forall a b c. (a -> b) -> Template b c -> Template a c
dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Template b c -> Template a d
$cdimap :: forall a b c d.
(a -> b) -> (c -> d) -> Template b c -> Template a d
Profunctor)

-- | We normally manipulate not 'Template's, but functions which
-- extend templates; this extracts a 'Template' from such a function
-- by applying it to the empty template.
makeTemplate :: (Monoid s) => (Template a s -> Template a s) -> Template a s
makeTemplate :: forall s a.
Monoid s =>
(Template a s -> Template a s) -> Template a s
makeTemplate Template a s -> Template a s
f = Template a s -> Template a s
f forall a. Monoid a => a
mempty


-- | A 'Context' records the situation part-way through a template (in
-- the middle of control structures, perhaps).
class Context s a r | r -> s, r -> a where
  -- | Append a template to a context
  prolong :: Template a s -> r -> r

-- | A 'Template' is the basic example of a 'Context'
instance Semigroup s => Context s a (Template a s) where
  prolong :: Template a s -> Template a s -> Template a s
prolong = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Semigroup a => a -> a -> a
(<>)

-- | Insert something computed from the template argument
embed :: (Context s a r) => (a -> s) -> r -> r
embed :: forall s a r. Context s a r => (a -> s) -> r -> r
embed = forall s a r. Context s a r => Template a s -> r -> r
prolong forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. (a -> s) -> Template a s
Template

-- | Insert something not depending upon the template argument
embedConst :: (Context s a r) => s -> r -> r
embedConst :: forall s a r. Context s a r => s -> r -> r
embedConst = forall s a r. Context s a r => (a -> s) -> r -> r
embed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Insert a string representation (obtained by @fromString . Show@)
-- derived from the template argument
embedShow :: (Context s a r, IsString s, Show b) => (a -> b) -> r -> r
embedShow :: forall s a r b.
(Context s a r, IsString s, Show b) =>
(a -> b) -> r -> r
embedShow a -> b
f = forall s a r. Context s a r => (a -> s) -> r -> r
embed (forall a. IsString a => String -> a
fromString 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
. a -> b
f)


-- | The 'ForContext' control structure iterates over any 'Foldable'
-- data structure: this is quite powerful, and can subsume many of
-- those control structures which follow.
data ForContext f s a b r = ForContext {
  forall (f :: * -> *) s a b r. ForContext f s a b r -> a -> f b
_variableFor :: a -> f b,
  forall (f :: * -> *) s a b r. ForContext f s a b r -> r
_previousFor :: r,
  forall (f :: * -> *) s a b r. ForContext f s a b r -> Template b s
_innerFor :: Template b s
}

instance (Semigroup s, Context s a r) => Context s b (ForContext f s a b r) where
  prolong :: Template b s -> ForContext f s a b r -> ForContext f s a b r
prolong Template b s
u (ForContext a -> f b
v r
p Template b s
t) = forall (f :: * -> *) s a b r.
(a -> f b) -> r -> Template b s -> ForContext f s a b r
ForContext a -> f b
v r
p (forall s a r. Context s a r => Template a s -> r -> r
prolong Template b s
u Template b s
t)

-- | This enters a 'ForContext'.
forH :: (Monoid s) => (a -> f b) -> r -> ForContext f s a b r
forH :: forall s a (f :: * -> *) b r.
Monoid s =>
(a -> f b) -> r -> ForContext f s a b r
forH a -> f b
v r
p = forall (f :: * -> *) s a b r.
(a -> f b) -> r -> Template b s -> ForContext f s a b r
ForContext a -> f b
v r
p forall a. Monoid a => a
mempty

-- | This exits from a 'ForContext'.
endfor :: (Monoid s, Context s a r, Foldable f) => ForContext f s a b r -> r
endfor :: forall s a r (f :: * -> *) b.
(Monoid s, Context s a r, Foldable f) =>
ForContext f s a b r -> r
endfor (ForContext a -> f b
v r
p Template b s
f) = forall s a r. Context s a r => Template a s -> r -> r
prolong (forall a s. (a -> s) -> Template a s
Template (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a s. Template a s -> a -> s
runTemplate Template b s
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
v)) r
p


-- | The 'IfContext' control structure is a slightly disguised
-- 'ForContext' (using 'Maybe').
newtype IfContext s a b r = IfContext {
  forall s a b r. IfContext s a b r -> ForContext Maybe s a b r
ifFor :: ForContext Maybe s a b r
}

instance (Semigroup s, Context s a r) => Context s b (IfContext s a b r) where
  prolong :: Template b s -> IfContext s a b r -> IfContext s a b r
prolong Template b s
u (IfContext ForContext Maybe s a b r
c) = forall s a b r. ForContext Maybe s a b r -> IfContext s a b r
IfContext (forall s a r. Context s a r => Template a s -> r -> r
prolong Template b s
u ForContext Maybe s a b r
c)

-- | This enters an 'IfContext'.
ifH :: (Monoid s) => (a -> Bool) -> r -> IfContext s a a r
ifH :: forall s a r. Monoid s => (a -> Bool) -> r -> IfContext s a a r
ifH a -> Bool
f = forall s a b r. ForContext Maybe s a b r -> IfContext s a b r
IfContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a (f :: * -> *) b r.
Monoid s =>
(a -> f b) -> r -> ForContext f s a b r
forH a -> Maybe a
g where
  g :: a -> Maybe a
g a
x = if a -> Bool
f a
x then forall a. a -> Maybe a
Just a
x else forall a. Maybe a
Nothing

-- | This exits from an 'IfContext'.
endif :: (Monoid s, Context s a r) => IfContext s a a r -> r
endif :: forall s a r. (Monoid s, Context s a r) => IfContext s a a r -> r
endif = forall s a r (f :: * -> *) b.
(Monoid s, Context s a r, Foldable f) =>
ForContext f s a b r -> r
endfor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b r. IfContext s a b r -> ForContext Maybe s a b r
ifFor


-- | The 'WithContext' control structure changes the argument to the
-- template temporarily. It is intended to be useful in situations
-- where tree-like data structures are passed as arguments, and there
-- is a section of the template where only one branch is of interest.
-- Again, this is a slightly disguised 'ForContext' (using 'Identity').
newtype WithContext s a b r = WithContext {
  forall s a b r. WithContext s a b r -> ForContext Identity s a b r
withFor :: ForContext Identity s a b r
}

instance (Semigroup s, Context s a r) => Context s b (WithContext s a b r) where
  prolong :: Template b s -> WithContext s a b r -> WithContext s a b r
prolong Template b s
u (WithContext ForContext Identity s a b r
c) = forall s a b r. ForContext Identity s a b r -> WithContext s a b r
WithContext (forall s a r. Context s a r => Template a s -> r -> r
prolong Template b s
u ForContext Identity s a b r
c)

-- | This enters a 'WithContext'.
withH :: (Monoid s) => (a -> b) -> r -> WithContext s a b r
withH :: forall s a b r. Monoid s => (a -> b) -> r -> WithContext s a b r
withH a -> b
f = forall s a b r. ForContext Identity s a b r -> WithContext s a b r
WithContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a (f :: * -> *) b r.
Monoid s =>
(a -> f b) -> r -> ForContext f s a b r
forH (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | This exits from a 'WithContext'.
endwith :: (Monoid s, Context s a r) => WithContext s a b r -> r
endwith :: forall s a r b.
(Monoid s, Context s a r) =>
WithContext s a b r -> r
endwith = forall s a r (f :: * -> *) b.
(Monoid s, Context s a r, Foldable f) =>
ForContext f s a b r -> r
endfor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b r. WithContext s a b r -> ForContext Identity s a b r
withFor


-- | The 'ProcessContext' control structure postprocesses the template
-- output in a region (unlike a 'WithContext', which preprocesses the
-- template argument).
data ProcessContext s t a r = ProcessContext {
  forall s t a r. ProcessContext s t a r -> t -> s
_mapProcess :: t -> s,
  forall s t a r. ProcessContext s t a r -> r
_previousProcess :: r,
  forall s t a r. ProcessContext s t a r -> Template a t
_innerProcess :: Template a t
}

instance (Semigroup t, Context s a r) => Context t a (ProcessContext s t a r) where
  prolong :: Template a t -> ProcessContext s t a r -> ProcessContext s t a r
prolong Template a t
u (ProcessContext t -> s
v r
p Template a t
t) = forall s t a r.
(t -> s) -> r -> Template a t -> ProcessContext s t a r
ProcessContext t -> s
v r
p (forall s a r. Context s a r => Template a s -> r -> r
prolong Template a t
u Template a t
t)

-- | This enters a 'ProcessContext'.
procH :: (Monoid t) => (t -> s) -> r -> ProcessContext s t a r
procH :: forall t s r a. Monoid t => (t -> s) -> r -> ProcessContext s t a r
procH t -> s
f r
p = forall s t a r.
(t -> s) -> r -> Template a t -> ProcessContext s t a r
ProcessContext t -> s
f r
p forall a. Monoid a => a
mempty

-- | This exits from a 'ProcessContext'.
endproc :: (Context s a r) => ProcessContext s t a r -> r
endproc :: forall s a r t. Context s a r => ProcessContext s t a r -> r
endproc (ProcessContext t -> s
f r
p Template a t
t) = forall s a r. Context s a r => Template a s -> r -> r
prolong (forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap t -> s
f Template a t
t) r
p