{-# 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 { Template a s -> a -> s
runTemplate :: a -> s }
  deriving (b -> Template a s -> Template a s
NonEmpty (Template a s) -> Template a s
Template a s -> Template a s -> Template a s
(Template a s -> Template a s -> Template a s)
-> (NonEmpty (Template a s) -> Template a s)
-> (forall b. Integral b => b -> Template a s -> Template a s)
-> Semigroup (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 :: 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, Semigroup (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] -> Template a s)
-> Monoid (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
$cp1Monoid :: forall a s. Monoid s => Semigroup (Template a s)
Monoid, q b c -> Template a b -> Template a c
Template b c -> q a b -> Template a c
(a -> b) -> (c -> d) -> Template b c -> Template a d
(a -> b) -> Template b c -> Template a c
(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. (a -> b) -> Template b c -> Template a c)
-> (forall b c a. (b -> c) -> Template a b -> Template a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible c b =>
    q b c -> Template a b -> Template a c)
-> (forall a b c (q :: * -> * -> *).
    Coercible b a =>
    Template b c -> q a b -> Template a c)
-> Profunctor Template
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
.# :: 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
#. :: 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 :: (b -> c) -> Template a b -> Template a c
$crmap :: forall b c a. (b -> c) -> Template a b -> Template a c
lmap :: (a -> b) -> Template b c -> Template a c
$clmap :: forall a b c. (a -> b) -> Template b c -> Template a c
dimap :: (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 :: (Template a s -> Template a s) -> Template a s
makeTemplate Template a s -> Template a s
f = Template a s -> Template a s
f Template a s
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 = (Template a s -> Template a s -> Template a s)
-> Template a s -> Template a s -> Template a s
forall a b c. (a -> b -> c) -> b -> a -> c
flip Template a s -> Template a s -> Template a s
forall a. Semigroup a => a -> a -> a
(<>)

-- | Insert something computed from the template argument
embed :: (Context s a r) => (a -> s) -> r -> r
embed :: (a -> s) -> r -> r
embed = Template a s -> r -> r
forall s a r. Context s a r => Template a s -> r -> r
prolong (Template a s -> r -> r)
-> ((a -> s) -> Template a s) -> (a -> s) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> s) -> Template a s
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 :: s -> r -> r
embedConst = (a -> s) -> r -> r
forall s a r. Context s a r => (a -> s) -> r -> r
embed ((a -> s) -> r -> r) -> (s -> a -> s) -> s -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a -> s
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 :: (a -> b) -> r -> r
embedShow a -> b
f = (a -> s) -> r -> r
forall s a r. Context s a r => (a -> s) -> r -> r
embed (String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (a -> String) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall a. Show a => a -> String
show (b -> String) -> (a -> b) -> a -> String
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 {
  ForContext f s a b r -> a -> f b
_variableFor :: a -> f b,
  ForContext f s a b r -> r
_previousFor :: 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) = (a -> f b) -> r -> Template b s -> ForContext f s a b r
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 (Template b s -> Template b s -> Template b s
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 :: (a -> f b) -> r -> ForContext f s a b r
forH a -> f b
v r
p = (a -> f b) -> r -> Template b s -> ForContext f s a b r
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 Template b s
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 :: ForContext f s a b r -> r
endfor (ForContext a -> f b
v r
p Template b s
f) = Template a s -> r -> r
forall s a r. Context s a r => Template a s -> r -> r
prolong ((a -> s) -> Template a s
forall a s. (a -> s) -> Template a s
Template ((b -> s) -> f b -> s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Template b s -> b -> s
forall a s. Template a s -> a -> s
runTemplate Template b s
f) (f b -> s) -> (a -> f b) -> a -> s
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 {
  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) = ForContext Maybe s a b r -> IfContext s a b r
forall s a b r. ForContext Maybe s a b r -> IfContext s a b r
IfContext (Template b s
-> ForContext Maybe s a b r -> ForContext Maybe s a b r
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 :: (a -> Bool) -> r -> IfContext s a a r
ifH a -> Bool
f = ForContext Maybe s a a r -> IfContext s a a r
forall s a b r. ForContext Maybe s a b r -> IfContext s a b r
IfContext (ForContext Maybe s a a r -> IfContext s a a r)
-> (r -> ForContext Maybe s a a r) -> r -> IfContext s a a r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> r -> ForContext Maybe s a a r
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 a -> Maybe a
forall a. a -> Maybe a
Just a
x else Maybe a
forall a. Maybe a
Nothing

-- | This exits from an 'IfContext'.
endif :: (Monoid s, Context s a r) => IfContext s a a r -> r
endif :: IfContext s a a r -> r
endif = ForContext Maybe s a a r -> r
forall s a r (f :: * -> *) b.
(Monoid s, Context s a r, Foldable f) =>
ForContext f s a b r -> r
endfor (ForContext Maybe s a a r -> r)
-> (IfContext s a a r -> ForContext Maybe s a a r)
-> IfContext s a a r
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfContext s a a r -> ForContext Maybe s a a r
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 {
  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) = ForContext Identity s a b r -> WithContext s a b r
forall s a b r. ForContext Identity s a b r -> WithContext s a b r
WithContext (Template b s
-> ForContext Identity s a b r -> ForContext Identity s a b r
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 :: (a -> b) -> r -> WithContext s a b r
withH a -> b
f = ForContext Identity s a b r -> WithContext s a b r
forall s a b r. ForContext Identity s a b r -> WithContext s a b r
WithContext (ForContext Identity s a b r -> WithContext s a b r)
-> (r -> ForContext Identity s a b r) -> r -> WithContext s a b r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> r -> ForContext Identity s a b r
forall s a (f :: * -> *) b r.
Monoid s =>
(a -> f b) -> r -> ForContext f s a b r
forH (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
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 :: WithContext s a b r -> r
endwith = ForContext Identity s a b r -> r
forall s a r (f :: * -> *) b.
(Monoid s, Context s a r, Foldable f) =>
ForContext f s a b r -> r
endfor (ForContext Identity s a b r -> r)
-> (WithContext s a b r -> ForContext Identity s a b r)
-> WithContext s a b r
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithContext s a b r -> ForContext Identity s a b r
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 {
  ProcessContext s t a r -> t -> s
_mapProcess :: t -> s,
  ProcessContext s t a r -> r
_previousProcess :: 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) = (t -> s) -> r -> Template a t -> ProcessContext s t a r
forall s t a r.
(t -> s) -> r -> Template a t -> ProcessContext s t a r
ProcessContext t -> s
v r
p (Template a t -> Template a t -> Template a t
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 :: (t -> s) -> r -> ProcessContext s t a r
procH t -> s
f r
p = (t -> s) -> r -> Template a t -> ProcessContext s t a r
forall s t a r.
(t -> s) -> r -> Template a t -> ProcessContext s t a r
ProcessContext t -> s
f r
p Template a t
forall a. Monoid a => a
mempty

-- | This exits from a 'ProcessContext'.
endproc :: (Context s a r) => ProcessContext s t a r -> r
endproc :: ProcessContext s t a r -> r
endproc (ProcessContext t -> s
f r
p Template a t
t) = Template a s -> r -> r
forall s a r. Context s a r => Template a s -> r -> r
prolong ((t -> s) -> Template a t -> Template a s
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