-- | Function for generating highlighted, hyperlinked HTML from Agda
-- sources.

module Agda.Interaction.Highlighting.HTML.Base
  ( HtmlOptions(..)
  , HtmlHighlight(..)
  , prepareCommonDestinationAssets
  , srcFileOfInterface
  , defaultPageGen
  , MonadLogHtml(logHtml)
  , LogHtmlT
  , runLogHtmlWith
  ) where

import Prelude hiding ((!!), concatMap)

import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans ( MonadIO(..), lift )
import Control.Monad.Trans.Reader ( ReaderT(runReaderT), ask )

import Data.Function ( on )
import Data.Foldable (toList, concatMap)
import Data.Maybe
import qualified Data.IntMap as IntMap
import qualified Data.List   as List
import Data.List.Split (splitWhen, chunksOf)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T

import GHC.Generics (Generic)

import qualified Network.URI.Encode

import System.FilePath
import System.Directory

import Text.Blaze.Html5
    ( preEscapedToHtml
    , toHtml
    , stringValue
    , Html
    , (!)
    , Attribute
    )
import qualified Text.Blaze.Html5 as Html5
import qualified Text.Blaze.Html5.Attributes as Attr
import Text.Blaze.Html.Renderer.Text ( renderHtml )
  -- The imported operator (!) attaches an Attribute to an Html value
  -- The defined operator (!!) attaches a list of such Attributes

import Paths_Agda

import Agda.Interaction.Highlighting.Precise hiding (toList)

import qualified Agda.Syntax.Concrete as C
import Agda.Syntax.Common

import qualified Agda.TypeChecking.Monad as TCM
  ( Interface(..)
  )

import Agda.Utils.Function
import qualified Agda.Utils.IO.UTF8 as UTF8
import Agda.Utils.Pretty

import Agda.Utils.Impossible

-- | The Agda data directory containing the files for the HTML backend.

htmlDataDir :: FilePath
htmlDataDir :: String
htmlDataDir = String
"html"

-- | The name of the default CSS file.

defaultCSSFile :: FilePath
defaultCSSFile :: String
defaultCSSFile = String
"Agda.css"

-- | The name of the occurrence-highlighting JS file.

occurrenceHighlightJsFile :: FilePath
occurrenceHighlightJsFile :: String
occurrenceHighlightJsFile = String
"highlight-hover.js"

-- | The directive inserted before the rendered code blocks

rstDelimiter :: String
rstDelimiter :: String
rstDelimiter = String
".. raw:: html\n"

-- | The directive inserted before rendered code blocks in org

orgDelimiterStart :: String
orgDelimiterStart :: String
orgDelimiterStart = String
"#+BEGIN_EXPORT html\n<pre class=\"Agda\">\n"

-- | The directive inserted after rendered code blocks in org

orgDelimiterEnd :: String
orgDelimiterEnd :: String
orgDelimiterEnd = String
"</pre>\n#+END_EXPORT\n"

-- | Determine how to highlight the file

data HtmlHighlight = HighlightAll | HighlightCode | HighlightAuto
  deriving (Key -> HtmlHighlight -> ShowS
[HtmlHighlight] -> ShowS
HtmlHighlight -> String
(Key -> HtmlHighlight -> ShowS)
-> (HtmlHighlight -> String)
-> ([HtmlHighlight] -> ShowS)
-> Show HtmlHighlight
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HtmlHighlight] -> ShowS
$cshowList :: [HtmlHighlight] -> ShowS
show :: HtmlHighlight -> String
$cshow :: HtmlHighlight -> String
showsPrec :: Key -> HtmlHighlight -> ShowS
$cshowsPrec :: Key -> HtmlHighlight -> ShowS
Show, HtmlHighlight -> HtmlHighlight -> Bool
(HtmlHighlight -> HtmlHighlight -> Bool)
-> (HtmlHighlight -> HtmlHighlight -> Bool) -> Eq HtmlHighlight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HtmlHighlight -> HtmlHighlight -> Bool
$c/= :: HtmlHighlight -> HtmlHighlight -> Bool
== :: HtmlHighlight -> HtmlHighlight -> Bool
$c== :: HtmlHighlight -> HtmlHighlight -> Bool
Eq, (forall x. HtmlHighlight -> Rep HtmlHighlight x)
-> (forall x. Rep HtmlHighlight x -> HtmlHighlight)
-> Generic HtmlHighlight
forall x. Rep HtmlHighlight x -> HtmlHighlight
forall x. HtmlHighlight -> Rep HtmlHighlight x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HtmlHighlight x -> HtmlHighlight
$cfrom :: forall x. HtmlHighlight -> Rep HtmlHighlight x
Generic)

instance NFData HtmlHighlight

highlightOnlyCode :: HtmlHighlight -> FileType -> Bool
highlightOnlyCode :: HtmlHighlight -> FileType -> Bool
highlightOnlyCode HtmlHighlight
HighlightAll  FileType
_ = Bool
False
highlightOnlyCode HtmlHighlight
HighlightCode FileType
_ = Bool
True
highlightOnlyCode HtmlHighlight
HighlightAuto FileType
AgdaFileType = Bool
False
highlightOnlyCode HtmlHighlight
HighlightAuto FileType
MdFileType   = Bool
True
highlightOnlyCode HtmlHighlight
HighlightAuto FileType
RstFileType  = Bool
True
highlightOnlyCode HtmlHighlight
HighlightAuto FileType
OrgFileType  = Bool
True
highlightOnlyCode HtmlHighlight
HighlightAuto FileType
TexFileType  = Bool
False

-- | Determine the generated file extension

highlightedFileExt :: HtmlHighlight -> FileType -> String
highlightedFileExt :: HtmlHighlight -> FileType -> String
highlightedFileExt HtmlHighlight
hh FileType
ft
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HtmlHighlight -> FileType -> Bool
highlightOnlyCode HtmlHighlight
hh FileType
ft = String
"html"
  | Bool
otherwise = case FileType
ft of
      FileType
AgdaFileType -> String
"html"
      FileType
MdFileType   -> String
"md"
      FileType
RstFileType  -> String
"rst"
      FileType
TexFileType  -> String
"tex"
      FileType
OrgFileType  -> String
"org"

-- | Options for HTML generation

data HtmlOptions = HtmlOptions
  { HtmlOptions -> String
htmlOptDir                  :: FilePath
  , HtmlOptions -> HtmlHighlight
htmlOptHighlight            :: HtmlHighlight
  , HtmlOptions -> Bool
htmlOptHighlightOccurrences :: Bool
  , HtmlOptions -> Maybe String
htmlOptCssFile              :: Maybe FilePath
  } deriving HtmlOptions -> HtmlOptions -> Bool
(HtmlOptions -> HtmlOptions -> Bool)
-> (HtmlOptions -> HtmlOptions -> Bool) -> Eq HtmlOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HtmlOptions -> HtmlOptions -> Bool
$c/= :: HtmlOptions -> HtmlOptions -> Bool
== :: HtmlOptions -> HtmlOptions -> Bool
$c== :: HtmlOptions -> HtmlOptions -> Bool
Eq

-- | Internal type bundling the information related to a module source file

data HtmlInputSourceFile = HtmlInputSourceFile
  { HtmlInputSourceFile -> TopLevelModuleName
_srcFileModuleName :: C.TopLevelModuleName
  , HtmlInputSourceFile -> FileType
_srcFileType :: FileType
  -- ^ Source file type
  , HtmlInputSourceFile -> Text
_srcFileText :: Text
  -- ^ Source text
  , HtmlInputSourceFile -> HighlightingInfo
_srcFileHighlightInfo :: HighlightingInfo
  -- ^ Highlighting info
  }

-- | Bundle up the highlighting info for a source file

srcFileOfInterface :: C.TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile
srcFileOfInterface :: TopLevelModuleName -> Interface -> HtmlInputSourceFile
srcFileOfInterface TopLevelModuleName
m Interface
i = TopLevelModuleName
-> FileType -> Text -> HighlightingInfo -> HtmlInputSourceFile
HtmlInputSourceFile TopLevelModuleName
m (Interface -> FileType
TCM.iFileType Interface
i) (Interface -> Text
TCM.iSource Interface
i) (Interface -> HighlightingInfo
TCM.iHighlighting Interface
i)

-- | Logging during HTML generation

type HtmlLogMessage = String
type HtmlLogAction m = HtmlLogMessage -> m ()

class MonadLogHtml m where
  logHtml :: HtmlLogAction m

type LogHtmlT m = ReaderT (HtmlLogAction m) m

instance Monad m => MonadLogHtml (LogHtmlT m) where
  logHtml :: HtmlLogAction (LogHtmlT m)
logHtml String
message = do
    HtmlLogAction m
doLog <- ReaderT (HtmlLogAction m) m (HtmlLogAction m)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    m () -> LogHtmlT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> LogHtmlT m ()) -> m () -> LogHtmlT m ()
forall a b. (a -> b) -> a -> b
$ HtmlLogAction m
doLog String
message

runLogHtmlWith :: Monad m => HtmlLogAction m -> LogHtmlT m a -> m a
runLogHtmlWith :: forall (m :: * -> *) a.
Monad m =>
HtmlLogAction m -> LogHtmlT m a -> m a
runLogHtmlWith = (LogHtmlT m a -> HtmlLogAction m -> m a)
-> HtmlLogAction m -> LogHtmlT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LogHtmlT m a -> HtmlLogAction m -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

renderSourceFile :: HtmlOptions -> HtmlInputSourceFile -> Text
renderSourceFile :: HtmlOptions -> HtmlInputSourceFile -> Text
renderSourceFile HtmlOptions
opts = HtmlInputSourceFile -> Text
renderSourcePage
  where
  cssFile :: String
cssFile = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultCSSFile (HtmlOptions -> Maybe String
htmlOptCssFile HtmlOptions
opts)
  highlightOccur :: Bool
highlightOccur = HtmlOptions -> Bool
htmlOptHighlightOccurrences HtmlOptions
opts
  htmlHighlight :: HtmlHighlight
htmlHighlight = HtmlOptions -> HtmlHighlight
htmlOptHighlight HtmlOptions
opts
  renderSourcePage :: HtmlInputSourceFile -> Text
renderSourcePage (HtmlInputSourceFile TopLevelModuleName
moduleName FileType
fileType Text
sourceCode HighlightingInfo
hinfo) =
    String -> Bool -> Bool -> TopLevelModuleName -> Html -> Text
page String
cssFile Bool
highlightOccur Bool
onlyCode TopLevelModuleName
moduleName Html
pageContents
    where
      tokens :: [TokenInfo]
tokens = Text -> HighlightingInfo -> [TokenInfo]
tokenStream Text
sourceCode HighlightingInfo
hinfo
      onlyCode :: Bool
onlyCode = HtmlHighlight -> FileType -> Bool
highlightOnlyCode HtmlHighlight
htmlHighlight FileType
fileType
      pageContents :: Html
pageContents = Bool -> FileType -> [TokenInfo] -> Html
code Bool
onlyCode FileType
fileType [TokenInfo]
tokens

defaultPageGen :: (MonadIO m, MonadLogHtml m) => HtmlOptions -> HtmlInputSourceFile -> m ()
defaultPageGen :: forall (m :: * -> *).
(MonadIO m, MonadLogHtml m) =>
HtmlOptions -> HtmlInputSourceFile -> m ()
defaultPageGen HtmlOptions
opts srcFile :: HtmlInputSourceFile
srcFile@(HtmlInputSourceFile TopLevelModuleName
moduleName FileType
ft Text
_ HighlightingInfo
_) = do
  HtmlLogAction m
forall (m :: * -> *). MonadLogHtml m => HtmlLogAction m
logHtml HtmlLogAction m -> HtmlLogAction m
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Doc
"Generating HTML for"  Doc -> Doc -> Doc
<+> TopLevelModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty TopLevelModuleName
moduleName Doc -> Doc -> Doc
<+> ((Doc -> Doc
parens (String -> Doc
forall a. Pretty a => a -> Doc
pretty String
target)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
".")
  Text -> HtmlLogAction m
forall (m :: * -> *). MonadIO m => Text -> String -> m ()
writeRenderedHtml Text
html String
target
  where
    ext :: String
ext = HtmlHighlight -> FileType -> String
highlightedFileExt (HtmlOptions -> HtmlHighlight
htmlOptHighlight HtmlOptions
opts) FileType
ft
    target :: String
target = (HtmlOptions -> String
htmlOptDir HtmlOptions
opts) String -> ShowS
</> TopLevelModuleName -> ShowS
modToFile TopLevelModuleName
moduleName String
ext
    html :: Text
html = HtmlOptions -> HtmlInputSourceFile -> Text
renderSourceFile HtmlOptions
opts HtmlInputSourceFile
srcFile

prepareCommonDestinationAssets :: MonadIO m => HtmlOptions -> m ()
prepareCommonDestinationAssets :: forall (m :: * -> *). MonadIO m => HtmlOptions -> m ()
prepareCommonDestinationAssets HtmlOptions
options = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  -- There is a default directory given by 'defaultHTMLDir'
  let htmlDir :: String
htmlDir = HtmlOptions -> String
htmlOptDir HtmlOptions
options
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
htmlDir

  -- If the default CSS file should be used, then it is copied to
  -- the output directory.
  let cssFile :: Maybe String
cssFile = HtmlOptions -> Maybe String
htmlOptCssFile HtmlOptions
options
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe String
cssFile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
defCssFile <- String -> IO String
getDataFileName (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
      String
htmlDataDir String -> ShowS
</> String
defaultCSSFile
    String -> String -> IO ()
copyFile String
defCssFile (String
htmlDir String -> ShowS
</> String
defaultCSSFile)

  let highlightOccurrences :: Bool
highlightOccurrences = HtmlOptions -> Bool
htmlOptHighlightOccurrences HtmlOptions
options
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
highlightOccurrences (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
highlightJsFile <- String -> IO String
getDataFileName (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
      String
htmlDataDir String -> ShowS
</> String
occurrenceHighlightJsFile
    String -> String -> IO ()
copyFile String
highlightJsFile (String
htmlDir String -> ShowS
</> String
occurrenceHighlightJsFile)

-- | Converts module names to the corresponding HTML file names.

modToFile :: C.TopLevelModuleName -> String -> FilePath
modToFile :: TopLevelModuleName -> ShowS
modToFile TopLevelModuleName
m String
ext = ShowS
Network.URI.Encode.encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (TopLevelModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty TopLevelModuleName
m) String -> ShowS
<.> String
ext

-- | Generates a highlighted, hyperlinked version of the given module.

writeRenderedHtml
  :: MonadIO m
  => Text       -- ^ Rendered page
  -> FilePath   -- ^ Output path.
  -> m ()
writeRenderedHtml :: forall (m :: * -> *). MonadIO m => Text -> String -> m ()
writeRenderedHtml Text
html String
target = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
UTF8.writeTextToFile String
target Text
html


-- | Attach multiple Attributes

(!!) :: Html -> [Attribute] -> Html
Html
h !! :: Html -> [Attribute] -> Html
!! [Attribute]
as = Html
h Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! [Attribute] -> Attribute
forall a. Monoid a => [a] -> a
mconcat [Attribute]
as

-- | Constructs the web page, including headers.

page :: FilePath              -- ^ URL to the CSS file.
     -> Bool                  -- ^ Highlight occurrences
     -> Bool                  -- ^ Whether to reserve literate
     -> C.TopLevelModuleName  -- ^ Module to be highlighted.
     -> Html
     -> Text
page :: String -> Bool -> Bool -> TopLevelModuleName -> Html -> Text
page String
css
     Bool
highlightOccurrences
     Bool
htmlHighlight
     TopLevelModuleName
modName
     Html
pageContent =
  Html -> Text
renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ if Bool
htmlHighlight
               then Html
pageContent
               else Html -> Html
Html5.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
hdr Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
rest
  where

    hdr :: Html
hdr = Html -> Html
Html5.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
      [ Html
Html5.meta Html -> [Attribute] -> Html
!! [ AttributeValue -> Attribute
Attr.charset AttributeValue
"utf-8" ]
      , Html -> Html
Html5.title (String -> Html
forall a. ToMarkup a => a -> Html
toHtml (String -> Html) -> (Doc -> String) -> Doc -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> Html) -> Doc -> Html
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty TopLevelModuleName
modName)
      , Html
Html5.link Html -> [Attribute] -> Html
!! [ AttributeValue -> Attribute
Attr.rel AttributeValue
"stylesheet"
                      , AttributeValue -> Attribute
Attr.href (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue String
css
                      ]
      , if Bool
highlightOccurrences
        then Html -> Html
Html5.script Html
forall a. Monoid a => a
mempty Html -> [Attribute] -> Html
!!
          [ AttributeValue -> Attribute
Attr.type_ AttributeValue
"text/javascript"
          , AttributeValue -> Attribute
Attr.src (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue String
occurrenceHighlightJsFile
          ]
        else Html
forall a. Monoid a => a
mempty
      ]

    rest :: Html
rest = Html -> Html
Html5.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ (Html -> Html
Html5.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Attr.class_ AttributeValue
"Agda") Html
pageContent

-- | Position, Contents, Infomation

type TokenInfo =
  ( Int
  , String
  , Aspects
  )

-- | Constructs token stream ready to print.

tokenStream
     :: Text             -- ^ The contents of the module.
     -> HighlightingInfo -- ^ Highlighting information.
     -> [TokenInfo]
tokenStream :: Text -> HighlightingInfo -> [TokenInfo]
tokenStream Text
contents HighlightingInfo
info =
  ([(Maybe Aspects, (Key, Char))] -> TokenInfo)
-> [[(Maybe Aspects, (Key, Char))]] -> [TokenInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\[(Maybe Aspects, (Key, Char))]
cs -> case [(Maybe Aspects, (Key, Char))]
cs of
          (Maybe Aspects
mi, (Key
pos, Char
_)) : [(Maybe Aspects, (Key, Char))]
_ ->
            (Key
pos, ((Maybe Aspects, (Key, Char)) -> Char)
-> [(Maybe Aspects, (Key, Char))] -> String
forall a b. (a -> b) -> [a] -> [b]
map ((Key, Char) -> Char
forall a b. (a, b) -> b
snd ((Key, Char) -> Char)
-> ((Maybe Aspects, (Key, Char)) -> (Key, Char))
-> (Maybe Aspects, (Key, Char))
-> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Aspects, (Key, Char)) -> (Key, Char)
forall a b. (a, b) -> b
snd) [(Maybe Aspects, (Key, Char))]
cs, Aspects -> Maybe Aspects -> Aspects
forall a. a -> Maybe a -> a
fromMaybe Aspects
forall a. Monoid a => a
mempty Maybe Aspects
mi)
          [] -> TokenInfo
forall a. HasCallStack => a
__IMPOSSIBLE__) ([[(Maybe Aspects, (Key, Char))]] -> [TokenInfo])
-> [[(Maybe Aspects, (Key, Char))]] -> [TokenInfo]
forall a b. (a -> b) -> a -> b
$
  ((Maybe Aspects, (Key, Char))
 -> (Maybe Aspects, (Key, Char)) -> Bool)
-> [(Maybe Aspects, (Key, Char))]
-> [[(Maybe Aspects, (Key, Char))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
List.groupBy (Maybe Aspects -> Maybe Aspects -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe Aspects -> Maybe Aspects -> Bool)
-> ((Maybe Aspects, (Key, Char)) -> Maybe Aspects)
-> (Maybe Aspects, (Key, Char))
-> (Maybe Aspects, (Key, Char))
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe Aspects, (Key, Char)) -> Maybe Aspects
forall a b. (a, b) -> a
fst) ([(Maybe Aspects, (Key, Char))]
 -> [[(Maybe Aspects, (Key, Char))]])
-> [(Maybe Aspects, (Key, Char))]
-> [[(Maybe Aspects, (Key, Char))]]
forall a b. (a -> b) -> a -> b
$
  (Key -> Char -> (Maybe Aspects, (Key, Char)))
-> [Key] -> String -> [(Maybe Aspects, (Key, Char))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key
pos Char
c -> (Key -> IntMap Aspects -> Maybe Aspects
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
pos IntMap Aspects
infoMap, (Key
pos, Char
c))) [Key
1..] (Text -> String
T.unpack Text
contents)
  where
  infoMap :: IntMap Aspects
infoMap = HighlightingInfo -> IntMap Aspects
forall a m. IsBasicRangeMap a m => m -> IntMap a
toMap HighlightingInfo
info

-- | Constructs the HTML displaying the code.

code :: Bool     -- ^ Whether to generate non-code contents as-is
     -> FileType -- ^ Source file type
     -> [TokenInfo]
     -> Html
code :: Bool -> FileType -> [TokenInfo] -> Html
code Bool
onlyCode FileType
fileType = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([TokenInfo] -> [Html]) -> [TokenInfo] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Bool
onlyCode
  then case FileType
fileType of
         -- Explicitly written all cases, so people
         -- get compile error when adding new file types
         -- when they forget to modify the code here
         FileType
RstFileType  -> ([TokenInfo] -> Html) -> [[TokenInfo]] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map [TokenInfo] -> Html
mkRst ([[TokenInfo]] -> [Html])
-> ([TokenInfo] -> [[TokenInfo]]) -> [TokenInfo] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
MdFileType   -> ([[TokenInfo]] -> Html) -> [[[TokenInfo]]] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map [[TokenInfo]] -> Html
mkMd ([[[TokenInfo]]] -> [Html])
-> ([TokenInfo] -> [[[TokenInfo]]]) -> [TokenInfo] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> [[TokenInfo]] -> [[[TokenInfo]]]
forall e. Key -> [e] -> [[e]]
chunksOf Key
2 ([[TokenInfo]] -> [[[TokenInfo]]])
-> ([TokenInfo] -> [[TokenInfo]]) -> [TokenInfo] -> [[[TokenInfo]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
AgdaFileType -> (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map TokenInfo -> Html
mkHtml
         -- Any points for using this option?
         FileType
TexFileType  -> ([[TokenInfo]] -> Html) -> [[[TokenInfo]]] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map [[TokenInfo]] -> Html
mkMd ([[[TokenInfo]]] -> [Html])
-> ([TokenInfo] -> [[[TokenInfo]]]) -> [TokenInfo] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> [[TokenInfo]] -> [[[TokenInfo]]]
forall e. Key -> [e] -> [[e]]
chunksOf Key
2 ([[TokenInfo]] -> [[[TokenInfo]]])
-> ([TokenInfo] -> [[TokenInfo]]) -> [TokenInfo] -> [[[TokenInfo]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
OrgFileType  -> ([TokenInfo] -> Html) -> [[TokenInfo]] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map [TokenInfo] -> Html
mkOrg ([[TokenInfo]] -> [Html])
-> ([TokenInfo] -> [[TokenInfo]]) -> [TokenInfo] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
  else (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map TokenInfo -> Html
mkHtml
  where
  trd :: (a, b, c) -> c
trd (a
_, b
_, c
a) = c
a

  splitByMarkup :: [TokenInfo] -> [[TokenInfo]]
  splitByMarkup :: [TokenInfo] -> [[TokenInfo]]
splitByMarkup = (TokenInfo -> Bool) -> [TokenInfo] -> [[TokenInfo]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen ((TokenInfo -> Bool) -> [TokenInfo] -> [[TokenInfo]])
-> (TokenInfo -> Bool) -> [TokenInfo] -> [[TokenInfo]]
forall a b. (a -> b) -> a -> b
$ (Maybe Aspect -> Maybe Aspect -> Bool
forall a. Eq a => a -> a -> Bool
== Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
Markup) (Maybe Aspect -> Bool)
-> (TokenInfo -> Maybe Aspect) -> TokenInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aspects -> Maybe Aspect
aspect (Aspects -> Maybe Aspect)
-> (TokenInfo -> Aspects) -> TokenInfo -> Maybe Aspect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenInfo -> Aspects
forall {a} {b} {c}. (a, b, c) -> c
trd

  mkHtml :: TokenInfo -> Html
  mkHtml :: TokenInfo -> Html
mkHtml (Key
pos, String
s, Aspects
mi) =
    -- Andreas, 2017-06-16, issue #2605:
    -- Do not create anchors for whitespace.
    Bool -> (Html -> Html) -> Html -> Html
forall a. Bool -> (a -> a) -> a -> a
applyUnless (Aspects
mi Aspects -> Aspects -> Bool
forall a. Eq a => a -> a -> Bool
== Aspects
forall a. Monoid a => a
mempty) (Key -> Aspects -> Html -> Html
annotate Key
pos Aspects
mi) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
s

  -- Proposed in #3373, implemented in #3384
  mkRst :: [TokenInfo] -> Html
  mkRst :: [TokenInfo] -> Html
mkRst = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([TokenInfo] -> [Html]) -> [TokenInfo] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
rstDelimiter Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
:) ([Html] -> [Html])
-> ([TokenInfo] -> [Html]) -> [TokenInfo] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map TokenInfo -> Html
go
    where
      go :: TokenInfo -> Html
go token :: TokenInfo
token@(Key
_, String
s, Aspects
mi) = if Aspects -> Maybe Aspect
aspect Aspects
mi Maybe Aspect -> Maybe Aspect -> Bool
forall a. Eq a => a -> a -> Bool
== Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
Background
        then String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml String
s
        else TokenInfo -> Html
mkHtml TokenInfo
token

  -- Proposed in #3137, implemented in #3313
  -- Improvement proposed in #3366, implemented in #3367
  mkMd :: [[TokenInfo]] -> Html
  mkMd :: [[TokenInfo]] -> Html
mkMd = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ([[TokenInfo]] -> [Html]) -> [[TokenInfo]] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TokenInfo]] -> [Html]
go
    where
      work :: TokenInfo -> Html
work token :: TokenInfo
token@(Key
_, String
s, Aspects
mi) = case Aspects -> Maybe Aspect
aspect Aspects
mi of
        Just Aspect
Background -> String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml String
s
        Just Aspect
Markup     -> Html
forall a. HasCallStack => a
__IMPOSSIBLE__
        Maybe Aspect
_               -> TokenInfo -> Html
mkHtml TokenInfo
token
      go :: [[TokenInfo]] -> [Html]
go [[TokenInfo]
a, [TokenInfo]
b] = [ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ TokenInfo -> Html
work (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
a
                  , Html -> Html
Html5.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Attr.class_ AttributeValue
"Agda" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ TokenInfo -> Html
work (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
b
                  ]
      go [[TokenInfo]
a]    = TokenInfo -> Html
work (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
a
      go [[TokenInfo]]
_      = [Html]
forall a. HasCallStack => a
__IMPOSSIBLE__

  mkOrg :: [TokenInfo] -> Html
  mkOrg :: [TokenInfo] -> Html
mkOrg [TokenInfo]
tokens = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ if Bool
containsCode then [Html]
formatCode else [Html]
formatNonCode
    where
      containsCode :: Bool
containsCode = (TokenInfo -> Bool) -> [TokenInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Maybe Aspect -> Maybe Aspect -> Bool
forall a. Eq a => a -> a -> Bool
/= Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
Background) (Maybe Aspect -> Bool)
-> (TokenInfo -> Maybe Aspect) -> TokenInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aspects -> Maybe Aspect
aspect (Aspects -> Maybe Aspect)
-> (TokenInfo -> Aspects) -> TokenInfo -> Maybe Aspect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenInfo -> Aspects
forall {a} {b} {c}. (a, b, c) -> c
trd) [TokenInfo]
tokens

      startDelimiter :: Html
startDelimiter = String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml String
orgDelimiterStart
      endDelimiter :: Html
endDelimiter = String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml String
orgDelimiterEnd

      formatCode :: [Html]
formatCode = Html
startDelimiter Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: (TokenInfo -> [Html] -> [Html]) -> [Html] -> [TokenInfo] -> [Html]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TokenInfo
x -> (TokenInfo -> Html
go TokenInfo
x Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
:)) [Html
endDelimiter] [TokenInfo]
tokens
      formatNonCode :: [Html]
formatNonCode = (TokenInfo -> Html) -> [TokenInfo] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map TokenInfo -> Html
go [TokenInfo]
tokens

      go :: TokenInfo -> Html
go token :: TokenInfo
token@(Key
_, String
s, Aspects
mi) = if Aspects -> Maybe Aspect
aspect Aspects
mi Maybe Aspect -> Maybe Aspect -> Bool
forall a. Eq a => a -> a -> Bool
== Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
Background
        then String -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml String
s
        else TokenInfo -> Html
mkHtml TokenInfo
token

  -- Put anchors that enable referencing that token.
  -- We put a fail safe numeric anchor (file position) for internal references
  -- (issue #2756), as well as a heuristic name anchor for external references
  -- (issue #2604).
  annotate :: Int -> Aspects -> Html -> Html
  annotate :: Key -> Aspects -> Html -> Html
annotate Key
pos Aspects
mi =
    Bool -> (Html -> Html) -> Html -> Html
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
hereAnchor ([Attribute] -> Html -> Html
anchorage [Attribute]
nameAttributes Html
forall a. Monoid a => a
mempty Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<>) (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Html -> Html
anchorage [Attribute]
posAttributes
    where
    -- Warp an anchor (<A> tag) with the given attributes around some HTML.
    anchorage :: [Attribute] -> Html -> Html
    anchorage :: [Attribute] -> Html -> Html
anchorage [Attribute]
attrs Html
html = Html -> Html
Html5.a Html
html Html -> [Attribute] -> Html
!! [Attribute]
attrs

    -- File position anchor (unique, reliable).
    posAttributes :: [Attribute]
    posAttributes :: [Attribute]
posAttributes = [[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [AttributeValue -> Attribute
Attr.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
pos ]
      , Maybe Attribute -> [Attribute]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Attribute -> [Attribute]) -> Maybe Attribute -> [Attribute]
forall a b. (a -> b) -> a -> b
$ DefinitionSite -> Attribute
link (DefinitionSite -> Attribute)
-> Maybe DefinitionSite -> Maybe Attribute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Aspects -> Maybe DefinitionSite
definitionSite Aspects
mi
      , AttributeValue -> Attribute
Attr.class_ (String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
classes) Attribute -> [()] -> [Attribute]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
classes)
      ]

    -- Named anchor (not reliable, but useful in the general case for outside refs).
    nameAttributes :: [Attribute]
    nameAttributes :: [Attribute]
nameAttributes = [ AttributeValue -> Attribute
Attr.id (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Maybe String
mDefSiteAnchor ]

    classes :: [String]
classes = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ (Char -> [String]) -> String -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [String]
forall {p} {a}. p -> [a]
noteClasses (Aspects -> String
note Aspects
mi)
      , [OtherAspect] -> [String]
otherAspectClasses (Set OtherAspect -> [OtherAspect]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set OtherAspect -> [OtherAspect])
-> Set OtherAspect -> [OtherAspect]
forall a b. (a -> b) -> a -> b
$ Aspects -> Set OtherAspect
otherAspects Aspects
mi)
      , (Aspect -> [String]) -> Maybe Aspect -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Aspect -> [String]
aspectClasses (Aspects -> Maybe Aspect
aspect Aspects
mi)
      ]

    aspectClasses :: Aspect -> [String]
aspectClasses (Name Maybe NameKind
mKind Bool
op) = [String]
kindClass [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
opClass
      where
      kindClass :: [String]
kindClass = Maybe String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ (NameKind -> String) -> Maybe NameKind -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NameKind -> String
showKind Maybe NameKind
mKind

      showKind :: NameKind -> String
showKind (Constructor Induction
Inductive)   = String
"InductiveConstructor"
      showKind (Constructor Induction
CoInductive) = String
"CoinductiveConstructor"
      showKind NameKind
k                         = NameKind -> String
forall a. Show a => a -> String
show NameKind
k

      opClass :: [String]
opClass = [String
"Operator" | Bool
op]
    aspectClasses Aspect
a = [Aspect -> String
forall a. Show a => a -> String
show Aspect
a]


    otherAspectClasses :: [OtherAspect] -> [String]
otherAspectClasses = (OtherAspect -> String) -> [OtherAspect] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map OtherAspect -> String
forall a. Show a => a -> String
show

    -- Notes are not included.
    noteClasses :: p -> [a]
noteClasses p
_s = []

    -- Should we output a named anchor?
    -- Only if we are at the definition site now (@here@)
    -- and such a pretty named anchor exists (see 'defSiteAnchor').
    hereAnchor      :: Bool
    hereAnchor :: Bool
hereAnchor      = Bool
here Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mDefSiteAnchor

    mDefinitionSite :: Maybe DefinitionSite
    mDefinitionSite :: Maybe DefinitionSite
mDefinitionSite = Aspects -> Maybe DefinitionSite
definitionSite Aspects
mi

    -- Are we at the definition site now?
    here            :: Bool
    here :: Bool
here            = Bool -> (DefinitionSite -> Bool) -> Maybe DefinitionSite -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False DefinitionSite -> Bool
defSiteHere Maybe DefinitionSite
mDefinitionSite

    mDefSiteAnchor  :: Maybe String
    mDefSiteAnchor :: Maybe String
mDefSiteAnchor  = Maybe String
-> (DefinitionSite -> Maybe String)
-> Maybe DefinitionSite
-> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
forall a. HasCallStack => a
__IMPOSSIBLE__ DefinitionSite -> Maybe String
defSiteAnchor Maybe DefinitionSite
mDefinitionSite

    link :: DefinitionSite -> Attribute
link (DefinitionSite TopLevelModuleName
m Key
defPos Bool
_here Maybe String
_aName) = AttributeValue -> Attribute
Attr.href (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$
      -- If the definition site points to the top of a file,
      -- we drop the anchor part and just link to the file.
      Bool -> ShowS -> ShowS
forall a. Bool -> (a -> a) -> a -> a
applyUnless (Key
defPos Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
1)
        (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++
         ShowS
Network.URI.Encode.encode (Key -> String
forall a. Show a => a -> String
show Key
defPos))
         -- Network.URI.Encode.encode (fromMaybe (show defPos) aName)) -- Named links disabled
        (ShowS
Network.URI.Encode.encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> ShowS
modToFile TopLevelModuleName
m String
"html")