{-# Language FlexibleInstances #-}
-- | Printing Monad. Starts with a specific data type (reader monad) and extends from there.
module Language.Drasil.TeX.Monad where

import Prelude hiding (print)
import qualified Text.PrettyPrint as TP

import Language.Drasil

import qualified Language.Drasil.Printing.Helpers as H

-----------------------------------------------------------------------------
-- * Printing Monad

-- first, start with a specific data type
-- note that this is just the Reader Monad for now, but we might need
-- to extend, so start there.

-- | There are two proper contexts, Text and Math; Curr is the current context.
-- There are multiple ways of getting there: for Text, either being at the top-level 
-- or inside \text. For Math, either surrounded by $ or 
-- in \begin{equation} .. \end{equation}.
-- Curr is when the current context is fine.
data MathContext = Text | Math | Curr deriving MathContext -> MathContext -> Bool
(MathContext -> MathContext -> Bool)
-> (MathContext -> MathContext -> Bool) -> Eq MathContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MathContext -> MathContext -> Bool
== :: MathContext -> MathContext -> Bool
$c/= :: MathContext -> MathContext -> Bool
/= :: MathContext -> MathContext -> Bool
Eq

-- | A monad for printing in LaTeX.
newtype PrintLaTeX a = PL { forall a. PrintLaTeX a -> MathContext -> a
runPrint :: MathContext -> a }

-- | Defines the printing monad as a functor.
instance Functor PrintLaTeX where
  fmap :: forall a b. (a -> b) -> PrintLaTeX a -> PrintLaTeX b
fmap a -> b
f (PL MathContext -> a
ca) = (MathContext -> b) -> PrintLaTeX b
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> b) -> PrintLaTeX b)
-> (MathContext -> b) -> PrintLaTeX b
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> a -> b
f (MathContext -> a
ca MathContext
ctx)

-- | This printing monad is also applicative.
instance Applicative PrintLaTeX where
  pure :: forall a. a -> PrintLaTeX a
pure = (MathContext -> a) -> PrintLaTeX a
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> a) -> PrintLaTeX a)
-> (a -> MathContext -> a) -> a -> PrintLaTeX a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MathContext -> a
forall a b. a -> b -> a
const
  PL MathContext -> a -> b
f <*> :: forall a b. PrintLaTeX (a -> b) -> PrintLaTeX a -> PrintLaTeX b
<*> PL MathContext -> a
v = (MathContext -> b) -> PrintLaTeX b
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> b) -> PrintLaTeX b)
-> (MathContext -> b) -> PrintLaTeX b
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> MathContext -> a -> b
f MathContext
ctx (MathContext -> a
v MathContext
ctx)

-- | Define the printing monad.
instance Monad PrintLaTeX where
  return :: forall a. a -> PrintLaTeX a
return = a -> PrintLaTeX a
forall a. a -> PrintLaTeX a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  PrintLaTeX a
m >>= :: forall a b. PrintLaTeX a -> (a -> PrintLaTeX b) -> PrintLaTeX b
>>= a -> PrintLaTeX b
k = (MathContext -> b) -> PrintLaTeX b
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> b) -> PrintLaTeX b)
-> (MathContext -> b) -> PrintLaTeX b
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> 
    let a :: a
a = PrintLaTeX a -> MathContext -> a
forall a. PrintLaTeX a -> MathContext -> a
runPrint PrintLaTeX a
m MathContext
ctx in
    PrintLaTeX b -> MathContext -> b
forall a. PrintLaTeX a -> MathContext -> a
runPrint (a -> PrintLaTeX b
k a
a) MathContext
ctx

-- | Convenient abbreviation.
type D = PrintLaTeX TP.Doc

-- | MonadReader calls this @local@.
-- Can switch contexts (including no-switch cases).  Adjust printing as necessary.
switch :: (MathContext -> MathContext) -> D -> D
switch :: (MathContext -> MathContext) -> D -> D
switch MathContext -> MathContext
f (PL MathContext -> Doc
g) = (MathContext -> Doc) -> D
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> Doc) -> D) -> (MathContext -> Doc) -> D
forall a b. (a -> b) -> a -> b
$ \MathContext
c -> MathContext -> MathContext -> (MathContext -> Doc) -> Doc
adjust MathContext
c (MathContext -> MathContext
f MathContext
c) MathContext -> Doc
g
  where
    bstext :: Doc
bstext = String -> Doc
TP.text String
"\\text"
    br :: Doc -> Doc
br Doc
doc = String -> Doc
TP.text String
"{" Doc -> Doc -> Doc
TP.<> Doc
doc Doc -> Doc -> Doc
TP.<> String -> Doc
TP.text String
"}"
    adjust :: MathContext -> MathContext -> (MathContext -> TP.Doc) -> TP.Doc
    adjust :: MathContext -> MathContext -> (MathContext -> Doc) -> Doc
adjust MathContext
Math MathContext
Math MathContext -> Doc
gen = MathContext -> Doc
gen MathContext
Math
    adjust MathContext
Text MathContext
Text MathContext -> Doc
gen = MathContext -> Doc
gen MathContext
Text
    -- we are producing Math, but want some Text embedded
    adjust MathContext
Math MathContext
Text MathContext -> Doc
gen = Doc
bstext Doc -> Doc -> Doc
TP.<> Doc -> Doc
br (MathContext -> Doc
gen MathContext
Text)
    -- we are producing Text, but want some Math embedded
    adjust MathContext
Text MathContext
Math MathContext -> Doc
gen = Doc -> Doc
H.dollarDoc (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ MathContext -> Doc
gen MathContext
Math
    adjust MathContext
Curr MathContext
Curr MathContext -> Doc
gen = MathContext -> Doc
gen MathContext
Text -- default
    adjust MathContext
Curr MathContext
x MathContext -> Doc
gen = MathContext -> Doc
gen MathContext
x
    adjust MathContext
x MathContext
Curr MathContext -> Doc
gen = MathContext -> Doc
gen MathContext
x 

toMath, toText :: D -> D
-- | Change context to Math.
toMath :: D -> D
toMath = (MathContext -> MathContext) -> D -> D
switch (MathContext -> MathContext -> MathContext
forall a b. a -> b -> a
const MathContext
Math)
-- | Change context to Text.
toText :: D -> D
toText = (MathContext -> MathContext) -> D -> D
switch (MathContext -> MathContext -> MathContext
forall a b. a -> b -> a
const MathContext
Text)

-- | MonadReader calls this @ask@.
getCtx :: PrintLaTeX MathContext
getCtx :: PrintLaTeX MathContext
getCtx = (MathContext -> MathContext) -> PrintLaTeX MathContext
forall a. (MathContext -> a) -> PrintLaTeX a
PL MathContext -> MathContext
forall a. a -> a
id

-- | D is a member of Semigroup.
instance Semigroup (PrintLaTeX TP.Doc) where
  (PL MathContext -> Doc
s1) <> :: D -> D -> D
<> (PL MathContext -> Doc
s2) = (MathContext -> Doc) -> D
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> Doc) -> D) -> (MathContext -> Doc) -> D
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> MathContext -> Doc
s1 MathContext
ctx Doc -> Doc -> Doc
TP.<> MathContext -> Doc
s2 MathContext
ctx

-- | D is a monoid.
instance Monoid (PrintLaTeX TP.Doc) where
  mempty :: D
mempty = Doc -> D
forall a. a -> PrintLaTeX a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc
TP.empty

-- may revisit later
-- | Since Text.PrettyPrint steals <>, use %% instead for $$.
infixl 5 %%
(%%) :: D -> D -> D
%% :: D -> D -> D
(%%) = (Doc -> Doc -> Doc) -> D -> D -> D
forall a b c.
(a -> b -> c) -> PrintLaTeX a -> PrintLaTeX b -> PrintLaTeX c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Doc -> Doc -> Doc
(TP.$$)

-- | Lifts Text.PrettyPrint's $+$. Above, with no overlapping. Associative.
infixr 6 $+$
($+$) :: D -> D -> D
$+$ :: D -> D -> D
($+$) = (Doc -> Doc -> Doc) -> D -> D -> D
forall a b c.
(a -> b -> c) -> PrintLaTeX a -> PrintLaTeX b -> PrintLaTeX c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Doc -> Doc -> Doc
(TP.$+$)

-- | Concatenates a list of 'D' using a function from ['TP.Doc'] -> 'TP.Doc'.
tpRunPrint :: ([TP.Doc] -> TP.Doc) -> [D] -> D
tpRunPrint :: ([Doc] -> Doc) -> [D] -> D
tpRunPrint [Doc] -> Doc
f [D]
l = (MathContext -> Doc) -> D
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> Doc) -> D) -> (MathContext -> Doc) -> D
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> [Doc] -> Doc
f ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (D -> Doc) -> [D] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (D -> MathContext -> Doc
forall a. PrintLaTeX a -> MathContext -> a
`runPrint` MathContext
ctx) [D]
l

-- | List version of 'TP.$$'. Above, except that if the last line of the first
-- argument stops at least one position before the first line of the second begins,
-- these two lines are overlapped.
vcat :: [D] -> D
vcat :: [D] -> D
vcat = ([Doc] -> Doc) -> [D] -> D
tpRunPrint [Doc] -> Doc
TP.vcat

-- Combine 'TP.vcat' and 'TP.punctuate'.
vpunctuate :: TP.Doc -> [D] -> D
vpunctuate :: Doc -> [D] -> D
vpunctuate Doc
x = ([Doc] -> Doc) -> [D] -> D
tpRunPrint ([Doc] -> Doc
TP.vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
TP.punctuate Doc
x)

-- Combine 'TP.hcat' and 'TP.punctuate'.
hpunctuate :: TP.Doc -> [D] -> D
hpunctuate :: Doc -> [D] -> D
hpunctuate Doc
x = ([Doc] -> Doc) -> [D] -> D
tpRunPrint ([Doc] -> Doc
TP.hcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
TP.punctuate Doc
x)

-- | Nest a 'D' by a specified indentation level.
nest :: Int -> D -> D
nest :: Int -> D -> D
nest Int
i (PL MathContext -> Doc
f) = (MathContext -> Doc) -> D
forall a. (MathContext -> a) -> PrintLaTeX a
PL ((MathContext -> Doc) -> D) -> (MathContext -> Doc) -> D
forall a b. (a -> b) -> a -> b
$ \MathContext
ctx -> Int -> Doc -> Doc
TP.nest Int
i (MathContext -> Doc
f MathContext
ctx)
--------
-- | MathContext operations.
lub :: MathContext -> MathContext -> MathContext
lub :: MathContext -> MathContext -> MathContext
lub MathContext
Math MathContext
Math = MathContext
Math
lub MathContext
Text MathContext
Text = MathContext
Text
lub MathContext
Curr MathContext
Curr = MathContext
Curr
lub MathContext
Curr MathContext
x    = MathContext
x
lub MathContext
x    MathContext
Curr = MathContext
x
lub MathContext
_    MathContext
_    = MathContext
Text -- Text is top-most

-----------------
-- Hacked up version, will get deleted
-- | Latex type. Holds 'String's.
newtype Latex = L { Latex -> String
unPL :: String }

-- | Renders special characters.
instance RenderSpecial Latex where
  special :: Special -> Latex
special Special
Circle       = String -> Latex
L String
"{}^{\\circ}"
  -- special Partial      = L "\\partial{}"