-- | This is a library which colourises Haskell code.
--   It currently has six output formats:
--
-- * ANSI terminal codes
--
-- * LaTeX macros
--
-- * HTML 3.2 with font tags
--
-- * HTML 4.01 with external CSS.
--
-- * XHTML 1.0 with internal CSS.
--
-- * mIRC chat client colour codes.
--
module Language.Haskell.HsColour (Output(..), ColourPrefs(..),
                                  hscolour) where

import Language.Haskell.HsColour.Colourise  (ColourPrefs(..))
import qualified Language.Haskell.HsColour.TTY        as TTY
import qualified Language.Haskell.HsColour.HTML       as HTML
import qualified Language.Haskell.HsColour.CSS        as CSS
import qualified Language.Haskell.HsColour.ACSS       as ACSS 
import qualified Language.Haskell.HsColour.InlineCSS  as ICSS
import qualified Language.Haskell.HsColour.LaTeX      as LaTeX
import qualified Language.Haskell.HsColour.MIRC       as MIRC
import Data.List(mapAccumL, isPrefixOf)
import Data.Maybe
import Language.Haskell.HsColour.Output
--import Debug.Trace

-- | Colourise Haskell source code with the given output format.
hscolour :: Output      -- ^ Output format.
         -> ColourPrefs -- ^ Colour preferences (for formats that support them).
         -> Bool        -- ^ Whether to include anchors.
         -> Bool        -- ^ Whether output document is partial or complete.
         -> String	-- ^ Title for output.
         -> Bool        -- ^ Whether input document is literate haskell or not
         -> String      -- ^ Haskell source code.
         -> String      -- ^ Coloured Haskell source code.
hscolour :: Output
-> ColourPrefs
-> Bool
-> Bool
-> String
-> Bool
-> String
-> String
hscolour output :: Output
output pref :: ColourPrefs
pref anchor :: Bool
anchor partial :: Bool
partial title :: String
title False =
        (if Bool
partial then String -> String
forall a. a -> a
id else Output -> String -> String -> String
top'n'tail Output
output String
title) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Output -> ColourPrefs -> Bool -> Int -> String -> String
hscolour' Output
output ColourPrefs
pref Bool
anchor 1
hscolour output :: Output
output pref :: ColourPrefs
pref anchor :: Bool
anchor partial :: Bool
partial title :: String
title True  =
        (if Bool
partial then String -> String
forall a. a -> a
id else Output -> String -> String -> String
top'n'tail Output
output String
title) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Lit] -> [String]
chunk 1 ([Lit] -> [String]) -> (String -> [Lit]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lit] -> [Lit]
joinL ([Lit] -> [Lit]) -> (String -> [Lit]) -> String -> [Lit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [Lit]
classify ([String] -> [Lit]) -> (String -> [String]) -> String -> [Lit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
inlines
  where
    chunk :: Int -> [Lit] -> [String]
chunk _        []     = []
    chunk n :: Int
n (Code c :: String
c: cs :: [Lit]
cs)  = Output -> ColourPrefs -> Bool -> Int -> String -> String
hscolour' Output
output ColourPrefs
pref Bool
anchor Int
n String
c
                              String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [Lit] -> [String]
chunk (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> [String]
lines String
c)) [Lit]
cs
    chunk n :: Int
n (Lit c :: String
c:  cs :: [Lit]
cs)  = String
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [Lit] -> [String]
chunk Int
n [Lit]
cs

-- | The actual colourising worker, despatched on the chosen output format.
hscolour' :: Output      -- ^ Output format.
          -> ColourPrefs -- ^ Colour preferences (for formats that support them)
          -> Bool        -- ^ Whether to include anchors.
          -> Int         -- ^ Starting line number (for line anchors)
          -> String      -- ^ Haskell source code.
          -> String      -- ^ Coloured Haskell source code.
hscolour' :: Output -> ColourPrefs -> Bool -> Int -> String -> String
hscolour' TTY       pref :: ColourPrefs
pref _      _ = ColourPrefs -> String -> String
TTY.hscolour     ColourPrefs
pref
hscolour' (TTYg tt :: TerminalType
tt) pref :: ColourPrefs
pref _      _ = TerminalType -> ColourPrefs -> String -> String
TTY.hscolourG TerminalType
tt ColourPrefs
pref
hscolour' MIRC      pref :: ColourPrefs
pref _      _ = ColourPrefs -> String -> String
MIRC.hscolour    ColourPrefs
pref
hscolour' LaTeX     pref :: ColourPrefs
pref _      _ = ColourPrefs -> String -> String
LaTeX.hscolour   ColourPrefs
pref
hscolour' HTML      pref :: ColourPrefs
pref anchor :: Bool
anchor n :: Int
n = ColourPrefs -> Bool -> Int -> String -> String
HTML.hscolour    ColourPrefs
pref Bool
anchor Int
n
hscolour' CSS       _    anchor :: Bool
anchor n :: Int
n = Bool -> Int -> String -> String
CSS.hscolour          Bool
anchor Int
n
hscolour' ICSS      pref :: ColourPrefs
pref anchor :: Bool
anchor n :: Int
n = ColourPrefs -> Bool -> Int -> String -> String
ICSS.hscolour    ColourPrefs
pref Bool
anchor Int
n
hscolour' ACSS      _    anchor :: Bool
anchor n :: Int
n = Bool -> Int -> String -> String
ACSS.hscolour         Bool
anchor Int
n

-- | Choose the right headers\/footers, depending on the output format.
top'n'tail :: Output           -- ^ Output format
           -> String           -- ^ Title for output
           -> (String->String) -- ^ Output transformer
top'n'tail :: Output -> String -> String -> String
top'n'tail TTY   _     = String -> String
forall a. a -> a
id
top'n'tail (TTYg _) _  = String -> String
forall a. a -> a
id
top'n'tail MIRC  _     = String -> String
forall a. a -> a
id
top'n'tail LaTeX title :: String
title = String -> String -> String
LaTeX.top'n'tail String
title
top'n'tail HTML  title :: String
title = String -> String -> String
HTML.top'n'tail String
title
top'n'tail CSS   title :: String
title = String -> String -> String
CSS.top'n'tail  String
title
top'n'tail ICSS  title :: String
title = String -> String -> String
ICSS.top'n'tail String
title
top'n'tail ACSS  title :: String
title = String -> String -> String
CSS.top'n'tail  String
title

-- | Separating literate files into code\/comment chunks.
data Lit = Code {Lit -> String
unL :: String} | Lit {unL :: String} deriving (Int -> Lit -> String -> String
[Lit] -> String -> String
Lit -> String
(Int -> Lit -> String -> String)
-> (Lit -> String) -> ([Lit] -> String -> String) -> Show Lit
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Lit] -> String -> String
$cshowList :: [Lit] -> String -> String
show :: Lit -> String
$cshow :: Lit -> String
showsPrec :: Int -> Lit -> String -> String
$cshowsPrec :: Int -> Lit -> String -> String
Show)

-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
-- And retains the trailing '\n' character in each resultant string.
inlines :: String -> [String]
inlines :: String -> [String]
inlines s :: String
s = String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id
  where
  lines' :: String -> (String -> String) -> [String]
lines' []             acc :: String -> String
acc = [String -> String
acc []]
  lines' ('\^M':'\n':s :: String
s) acc :: String -> String
acc = String -> String
acc ['\n'] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id	-- DOS
--lines' ('\^M':s)      acc = acc ['\n'] : lines' s id	-- MacOS
  lines' ('\n':s :: String
s)       acc :: String -> String
acc = String -> String
acc ['\n'] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> (String -> String) -> [String]
lines' String
s String -> String
forall a. a -> a
id	-- Unix
  lines' (c :: Char
c:s :: String
s)          acc :: String -> String
acc = String -> (String -> String) -> [String]
lines' String
s (String -> String
acc (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:))


-- | The code for classify is largely stolen from Language.Preprocessor.Unlit.
classify ::  [String] -> [Lit]
classify :: [String] -> [Lit]
classify []             = []
classify (x :: String
x:xs :: [String]
xs) | "\\begin{code}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
x
                        = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: String -> [String] -> [Lit]
allProg "code" [String]
xs
classify (x :: String
x:xs :: [String]
xs) | "\\begin{spec}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
x
                        = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: String -> [String] -> [Lit]
allProg "spec" [String]
xs
classify (('>':x :: String
x):xs :: [String]
xs)   = String -> Lit
Code ('>'Char -> String -> String
forall a. a -> [a] -> [a]
:String
x) Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
classify [String]
xs
classify (x :: String
x:xs :: [String]
xs)         = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
classify [String]
xs


allProg :: String -> [String] -> [Lit]
allProg name :: String
name  = [String] -> [Lit]
go 
  where
    end :: String
end       = "\\end{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}"
    go :: [String] -> [Lit]
go []     = []  -- Should give an error message,
                    -- but I have no good position information.
    go (x :: String
x:xs :: [String]
xs) | String
end `isPrefixOf `String
x
              = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
classify [String]
xs
    go (x :: String
x:xs :: [String]
xs) = String -> Lit
Code String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
go [String]
xs

-- | Join up chunks of code\/comment that are next to each other.
joinL :: [Lit] -> [Lit]
joinL :: [Lit] -> [Lit]
joinL []                  = []
joinL (Code c :: String
c:Code c2 :: String
c2:xs :: [Lit]
xs) = [Lit] -> [Lit]
joinL (String -> Lit
Code (String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit c :: String
c :Lit c2 :: String
c2 :xs :: [Lit]
xs) = [Lit] -> [Lit]
joinL (String -> Lit
Lit  (String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (any :: Lit
any:xs :: [Lit]
xs)            = Lit
anyLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit] -> [Lit]
joinL [Lit]
xs