-- | 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 Agda.Syntax.Common
import Agda.Syntax.TopLevelModuleName

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
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
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. 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 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
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 :: 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 ::
  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 <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = 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
  forall (m :: * -> *). MonadLogHtml m => HtmlLogAction m
logHtml forall a b. (a -> b) -> a -> b
$ Doc -> String
render forall a b. (a -> b) -> a -> b
$ Doc
"Generating HTML for"  Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty TopLevelModuleName
moduleName Doc -> Doc -> Doc
<+> ((Doc -> Doc
parens (forall a. Pretty a => a -> Doc
pretty String
target)) forall a. Semigroup a => a -> a -> a
<> Doc
".")
  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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Maybe String
cssFile) forall a b. (a -> b) -> a -> b
$ do
    String
defCssFile <- String -> IO String
getDataFileName 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
highlightOccurrences forall a b. (a -> b) -> a -> b
$ do
    String
highlightJsFile <- String -> IO String
getDataFileName 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 :: TopLevelModuleName -> String -> FilePath
modToFile :: TopLevelModuleName -> ShowS
modToFile TopLevelModuleName
m String
ext = ShowS
Network.URI.Encode.encode forall a b. (a -> b) -> a -> b
$ Doc -> String
render (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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall h. Attributable h => h -> Attribute -> h
! 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
     -> 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 forall a b. (a -> b) -> a -> b
$ if Bool
htmlHighlight
               then Html
pageContent
               else Html -> Html
Html5.docTypeHtml forall a b. (a -> b) -> a -> b
$ Html
hdr forall a. Semigroup a => a -> a -> a
<> Html
rest
  where

    hdr :: Html
hdr = Html -> Html
Html5.head forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ Html
Html5.meta Html -> [Attribute] -> Html
!! [ AttributeValue -> Attribute
Attr.charset AttributeValue
"utf-8" ]
      , Html -> Html
Html5.title (forall a. ToMarkup a => a -> Html
toHtml forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue String
css
                      ]
      , if Bool
highlightOccurrences
        then Html -> Html
Html5.script forall a. Monoid a => a
mempty Html -> [Attribute] -> Html
!!
          [ AttributeValue -> Attribute
Attr.type_ AttributeValue
"text/javascript"
          , AttributeValue -> Attribute
Attr.src forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue String
occurrenceHighlightJsFile
          ]
        else forall a. Monoid a => a
mempty
      ]

    rest :: Html
rest = Html -> Html
Html5.body forall a b. (a -> b) -> a -> b
$ (Html -> Html
Html5.pre 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 =
  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, forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe Aspects, (Key, Char))]
cs, forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe Aspects
mi)
          [] -> forall a. HasCallStack => a
__IMPOSSIBLE__) forall a b. (a -> b) -> a -> b
$
  forall a. (a -> a -> Bool) -> [a] -> [[a]]
List.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
  forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Key
pos Char
c -> (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 = 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 = forall a. Monoid a => [a] -> a
mconcat 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  -> forall a b. (a -> b) -> [a] -> [b]
map [TokenInfo] -> Html
mkRst forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
MdFileType   -> forall a b. (a -> b) -> [a] -> [b]
map [[TokenInfo]] -> Html
mkMd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Key -> [e] -> [[e]]
chunksOf Key
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
AgdaFileType -> forall a b. (a -> b) -> [a] -> [b]
map TokenInfo -> Html
mkHtml
         -- Any points for using this option?
         FileType
TexFileType  -> forall a b. (a -> b) -> [a] -> [b]
map [[TokenInfo]] -> Html
mkMd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Key -> [e] -> [[e]]
chunksOf Key
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
         FileType
OrgFileType  -> forall a b. (a -> b) -> [a] -> [b]
map [TokenInfo] -> Html
mkOrg forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokenInfo] -> [[TokenInfo]]
splitByMarkup
  else 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 = forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen forall a b. (a -> b) -> a -> b
$ (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Aspect
Markup) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aspects -> Maybe Aspect
aspect forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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.
    forall a. Bool -> (a -> a) -> a -> a
applyUnless (Aspects
mi forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) (Key -> Aspects -> Html -> Html
annotate Key
pos Aspects
mi) forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
toHtml String
s

  -- Proposed in #3373, implemented in #3384
  mkRst :: [TokenInfo] -> Html
  mkRst :: [TokenInfo] -> Html
mkRst = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToMarkup a => a -> Html
toHtml String
rstDelimiter forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Aspect
Background
        then 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 = forall a. Monoid a => [a] -> a
mconcat 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 -> forall a. ToMarkup a => a -> Html
preEscapedToHtml String
s
        Just Aspect
Markup     -> forall a. HasCallStack => a
__IMPOSSIBLE__
        Maybe Aspect
_               -> TokenInfo -> Html
mkHtml TokenInfo
token
      go :: [[TokenInfo]] -> [Html]
go [[TokenInfo]
a, [TokenInfo]
b] = [ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ TokenInfo -> Html
work forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
a
                  , Html -> Html
Html5.pre forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
Attr.class_ AttributeValue
"Agda" forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ TokenInfo -> Html
work forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
b
                  ]
      go [[TokenInfo]
a]    = TokenInfo -> Html
work forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenInfo]
a
      go [[TokenInfo]]
_      = forall a. HasCallStack => a
__IMPOSSIBLE__

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

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

      formatCode :: [Html]
formatCode = Html
startDelimiter forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TokenInfo
x -> (TokenInfo -> Html
go TokenInfo
x forall a. a -> [a] -> [a]
:)) [Html
endDelimiter] [TokenInfo]
tokens
      formatNonCode :: [Html]
formatNonCode = 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Aspect
Background
        then 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 =
    forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
hereAnchor ([Attribute] -> Html -> Html
anchorage [Attribute]
nameAttributes forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<>) 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [AttributeValue -> Attribute
Attr.id forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Key
pos ]
      , forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ DefinitionSite -> Attribute
link 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 forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
classes) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ Maybe String
mDefSiteAnchor ]

    classes :: [String]
classes = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {p} {a}. p -> [a]
noteClasses (Aspects -> String
note Aspects
mi)
      , [OtherAspect] -> [String]
otherAspectClasses (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Aspects -> Set OtherAspect
otherAspects Aspects
mi)
      , 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 forall a. [a] -> [a] -> [a]
++ [String]
opClass
      where
      kindClass :: [String]
kindClass = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ 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                         = forall a. Show a => a -> String
show NameKind
k

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


    otherAspectClasses :: [OtherAspect] -> [String]
otherAspectClasses = forall a b. (a -> b) -> [a] -> [b]
map 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
&& 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            = 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  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe 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 forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
stringValue 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.
      forall a. Bool -> (a -> a) -> a -> a
applyUnless (Key
defPos forall a. Ord a => a -> a -> Bool
<= Key
1)
        (forall a. [a] -> [a] -> [a]
++ String
"#" forall a. [a] -> [a] -> [a]
++
         ShowS
Network.URI.Encode.encode (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 forall a b. (a -> b) -> a -> b
$ TopLevelModuleName -> ShowS
modToFile TopLevelModuleName
m String
"html")