content: {-# LANGUAGE LambdaCase        #-}
  {-# LANGUAGE NamedFieldPuns    #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards   #-}
  {-# LANGUAGE ViewPatterns      #-}
  
  {-| Contains the logic to render the source code inside a HTML. It also provides
      context-sensitive features such as jump-to-definition.
  
      Rendering an expression consists on the following steps:
  
      * An 'Expr Src Import' with its parsed 'Text' is processed into
        a '[SourceCodeFragment]'
      * Each 'SourceCodeFragment' tells the 'renderSourceCodeFragment' how to
        render that function as HTML including the injected information through
        HTML data-attributes
  
      To render a Dhall file you should use 'renderCodeWithHyperLinks' which
      takes a 'Text' that was used to parse the 'Expr Src Import', and returns
      the generated 'Html ()' with the same structure (i.e. whitespaces)
      from the 'Text' argument.
  
      To render code-snippets (e.g. assertions from examples, type from source code)
      you should use 'renderCodeSnippet' which uses the output of @dhall format@
      as the 'Text' argument to call later 'renderCodeWithHyperLinks'
  -}
  module Dhall.Docs.CodeRenderer
      ( renderCodeWithHyperLinks
      , renderCodeSnippet
      , ExprType(..)
      ) where
  
  import Control.Monad.Trans.Writer.Strict (Writer)
  import Data.Text                         (Text)
  import Data.Void                         (Void)
  import Dhall.Context                     (Context)
  import Dhall.Core
      ( Binding (..)
      , Expr (..)
      , FieldSelection (..)
      , File (..)
      , FilePrefix (..)
      , FunctionBinding (..)
      , Import (..)
      , ImportHashed (..)
      , ImportType (..)
      , RecordField (..)
      , Scheme (..)
      , URL (..)
      , Var (..)
      )
  import Dhall.Docs.Util
  import Dhall.Src                         (Src (..))
  import Lucid
  import Text.Megaparsec.Pos               (SourcePos (..))
  
  import qualified Control.Monad.Trans.Writer.Strict as Writer
  import qualified Data.List
  import qualified Data.Maybe                        as Maybe
  import qualified Data.Set                          as Set
  import qualified Data.Text                         as Text
  import qualified Dhall.Context                     as Context
  import qualified Dhall.Core                        as Core
  import qualified Dhall.Map                         as Map
  import qualified Dhall.Parser
  import qualified Dhall.Pretty
  import qualified Lens.Micro                        as Lens
  import qualified Prettyprinter                     as Pretty
  import qualified Prettyprinter.Render.Text         as Pretty.Text
  import qualified Text.Megaparsec.Pos               as SourcePos
  
  -- $setup
  -- >>> :set -XOverloadedStrings
  -- >>> import Dhall.Core (Directory (..))
  
  -- | Get the source line and column from a 'SourcePos' as an 'Int'
  getSourceLine, getSourceColumn :: SourcePos -> Int
  getSourceLine = SourcePos.unPos . SourcePos.sourceLine
  getSourceColumn = SourcePos.unPos . SourcePos.sourceColumn
  
  {-| Every 'Expr' constructor has extra information that tell us what to highlight on
      hover and where to jump on click events. 'JtdInfo' record that extra
      information.
  -}
  data JtdInfo
      {-| Each field in a Dhall record (type or literal) is associated with a
          'NameDecl', and selector-expressions behave like 'Var's by using a
          'NameUse' with the field 'NameDecl' to jump to that label.
  
          For example, a Dhall expression like this:
  
          > { a = foo, b = bar }
  
          has the following 'JtdInfo':
  
          > RecordFields (Set.fromList [NameDecl posA "a" jtdInfoA, NameDecl posB "b" jtdInfoB])
  
          ... where
  
          * @posA@ and @posB@ record the source position used to make them
          unique across the rendered source code
          * @jtdInfoA@ and @jtdInfoB@ are the associated 'JtdInfo' inferred from
          @foo@ and @bar@
      -}
      = RecordFields (Set.Set NameDecl)
      -- | Default type for cases we don't handle
      | NoInfo
      deriving (Eq, Ord, Show)
  
  {-| To make each name unique we record the source position where it was
      found.
  
      The names that we handle are the ones introduced by let-bindings, lambda
      arguments and record (types and literals) labels.
  -}
  data NameDecl = NameDecl Src Text JtdInfo
      deriving (Eq, Ord, Show)
  
  makeHtmlId :: NameDecl -> Text
  makeHtmlId (NameDecl Src{srcStart} _ _) =
         "var"
      <> Text.pack (show $ getSourceLine srcStart) <> "-"
      <> Text.pack (show $ getSourceColumn srcStart)
  
  -- | Available ways of rendering source code as HTML
  data SourceCodeType
      -- | Relative and remote imports are rendered using an HTML anchor tag.
      --   Other imports are rendered as plain-text
      = ImportExpr Import
  
      -- | Used to render a name declared in let-binding or function argument
      --   that is used in any expression
      | NameUse NameDecl
  
      -- | Used to render the declaration of a name. This is used to jump
      --   to that name after clicking an 'NameUse'
      | NameDeclaration NameDecl
  
  {-| The 'Expr Src Import' parsed from a 'Text' is split into a
      '[SourceCodeFragment]'.
  -}
  data SourceCodeFragment =
      SourceCodeFragment
          Src -- ^ The start and end position of this fragment
          SourceCodeType -- ^ The type of 'SourceCodeFragment' that will guide HTML rendering
  
  -- | Returns all 'SourceCodeFragment's in lexicographic order i.e. in the same
  --   order as in the source code.
  fragments :: Expr Src Import -> [SourceCodeFragment]
  fragments = Data.List.sortBy sorter . removeUnusedDecls . Writer.execWriter . infer Context.empty
    where
      sorter (SourceCodeFragment Src{srcStart = srcStart0} _)
             (SourceCodeFragment Src{srcStart = srcStart1} _) = pos0 `compare` pos1
        where
          pos0 = (getSourceLine srcStart0, getSourceColumn srcStart0)
          pos1 = (getSourceLine srcStart1, getSourceColumn srcStart1)
  
      removeUnusedDecls sourceCodeFragments = filter isUsed sourceCodeFragments
        where
          makePosPair Src{srcStart} = (getSourceLine srcStart, getSourceColumn srcStart)
          nameUsePos (SourceCodeFragment _ (NameUse (NameDecl src _ _))) =
              Just $ makePosPair src
          nameUsePos _ = Nothing
  
          usedNames = Set.fromList $ Maybe.mapMaybe nameUsePos sourceCodeFragments
  
          isUsed (SourceCodeFragment _ (NameDeclaration (NameDecl src _ _))) =
              makePosPair src `Set.member` usedNames
          isUsed _ = True
  
      infer :: Context NameDecl -> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
      infer context = \case
          -- The parsed text of the import is located in it's `Note` constructor
          Note src (Embed a) -> Writer.tell [SourceCodeFragment src $ ImportExpr a] >> return NoInfo
  
          -- since we have to 'infer' the 'JtdInfo' of the annotation, we
          -- are not able to generate the 'SourceCodeFragment's in lexicographical
          -- without calling 'Data.List.sortBy' after
          Let (Binding
                  (Just Src { srcEnd = srcEnd0 })
                  name
                  (Just Src { srcStart = srcStart1 })
                  annotation
                  _
                  value) expr' -> do
  
              -- If annotation is missing, the type is inferred from the bound value
              case annotation of
                  Nothing -> return ()
                  Just (_, t) -> do
                      _ <- infer context t
                      return ()
  
              bindingJtdInfo <- infer context value
  
              let nameSrc = makeSrcForLabel srcEnd0 srcStart1 name
              let nameDecl = NameDecl nameSrc name bindingJtdInfo
  
              Writer.tell [SourceCodeFragment nameSrc (NameDeclaration nameDecl)]
              infer (Context.insert name nameDecl context) expr'
  
          Note src (Var (V name index)) ->
              case Context.lookup name index context of
                  Nothing -> return NoInfo
                  Just nameDecl@(NameDecl _ _ t) -> do
                      Writer.tell [SourceCodeFragment src $ NameUse nameDecl]
                      return t
  
          Lam _ (FunctionBinding
                  (Just Src{srcEnd = srcEnd0})
                  name
                  (Just Src{srcStart = srcStart1})
                  _
                  t) expr -> do
              dhallType <- infer context t
  
              let nameSrc = makeSrcForLabel srcEnd0 srcStart1 name
              let nameDecl = NameDecl nameSrc name dhallType
  
              Writer.tell [SourceCodeFragment nameSrc (NameDeclaration nameDecl)]
              infer (Context.insert name nameDecl context) expr
  
          Field e (FieldSelection (Just Src{srcEnd=posStart}) label (Just Src{srcStart=posEnd})) -> do
              fields <- do
                  dhallType <- infer context e
                  case dhallType of
                      NoInfo -> return mempty
                      RecordFields s -> return $ Set.toList s
  
              let src = makeSrcForLabel posStart posEnd label
              let match (NameDecl _ l _) = l == label
              case filter match fields of
                  x@(NameDecl _ _ t) : _ -> do
                      Writer.tell [SourceCodeFragment src (NameUse x)]
                      return t
                  _ -> return NoInfo
  
          RecordLit (Map.toList -> l) -> handleRecordLike l
  
          Record (Map.toList -> l) -> handleRecordLike l
  
          Note _ e -> infer context e
          e -> do
              mapM_ (infer context) $ Lens.toListOf Core.subExpressions e
              return NoInfo
  
        where
          handleRecordLike l = RecordFields . Set.fromList . concat <$> mapM f l
            where
              f (key, RecordField (Just Src{srcEnd = startPos}) val (Just Src{srcStart = endPos}) _) = do
                  dhallType <- infer context val
                  let nameSrc = makeSrcForLabel startPos endPos key
                  let nameDecl = NameDecl nameSrc key dhallType
                  Writer.tell [SourceCodeFragment nameSrc (NameDeclaration nameDecl)]
                  return [ nameDecl ]
                where
              f _ = return [ ]
  
  fileAsText :: File -> Text
  fileAsText File{..} = foldr (\d acc -> acc <> "/" <> d) "" (Core.components directory)
      <> "/" <> file
  
  -- | Generic way of creating a Src for a label, taking quoted names into
  --   account
  makeSrcForLabel
      :: SourcePos  -- ^ Prefix whitespace end position, will be 'srcStart'
      -> SourcePos  -- ^ Suffix whitespace start position, will be 'srcEnd'
      -> Text       -- ^ Label name, will be the 'srcText' with surrounding @`@ if needed
      -> Src
  makeSrcForLabel srcStart srcEnd name = Src {..}
    where
      realLength = getSourceColumn srcEnd - getSourceColumn srcStart
      srcText =
          if Text.length name == realLength then name
          else "`" <> name <> "`"
  
  renderSourceCodeFragment :: SourceCodeFragment -> Html ()
  renderSourceCodeFragment (SourceCodeFragment Src{..} (ImportExpr import_)) =
      renderImport import_ srcText
    where
      {-  Given an 'Import', render the contents in an HTML element that will allow
          users to jump to another file or domain. The 'Text' argument is the contents
          inside the anchor tag
  
          Example:
  
          >>> :set -Wno-missing-fields
          >>> let file = File { directory = Directory [], file = ""}
          >>> let url = URL { scheme = HTTPS, authority = "google.com", query = Nothing, path = file}
          >>> let import_ = Import {importHashed = ImportHashed { importType = Remote url }}
          >>> renderImport import_ "link for google"
          <a href="https://google.com/" target="_blank">link for google</a>
      -}
      renderImport :: Import -> Text -> Html ()
      renderImport (Import {importHashed = ImportHashed { importType }}) =
          case importType of
              Remote URL {..} -> a_ [href_ href, target_ "_blank"] . toHtml
                where
                  scheme_ = case scheme of
                      HTTP -> "http"
                      HTTPS -> "https"
  
                  path_ = fileAsText path
  
                  query_ = case query of
                      Nothing -> ""
                      Just d -> "?" <> d
  
                  -- we don't include the headers here since we treat links to open a file
                  -- in another tab
                  href = scheme_ <> "://" <> authority <> path_ <> query_
  
              Local Here file -> a_ [href_ href] . toHtml
                where
                  href = "." <> fileAsText file <> ".html"
  
              Local Parent file -> a_ [href_ href] . toHtml
                where
                  href = ".." <> fileAsText file <> ".html"
  
              _ -> toHtml
  
  renderSourceCodeFragment (SourceCodeFragment Src{..} (NameDeclaration nameDecl)) =
      span_ attributes $ toHtml srcText
    where
      attributes =
          [id_ $ makeHtmlId nameDecl
          , class_ "name-decl"
          , data_ "name" $ makeHtmlId nameDecl ]
  renderSourceCodeFragment (SourceCodeFragment Src{..} (NameUse nameDecl)) =
      a_ attributes $ toHtml srcText
    where
      attributes =
          [ href_ $ "#" <> makeHtmlId nameDecl
          , class_ "name-use"
          , data_ "name" $ makeHtmlId nameDecl
          ]
  
  -- | Given a Text and the parsed `Expr Src Import` from it, this will render the
  --   the source code on HTML with jump-to-definition on URL imports. Use this
  --   to render the source code with the same structure (whitespaces, comments,
  --   language elements) as the source file
  renderCodeWithHyperLinks :: Text -> Expr Src Import -> Html ()
  renderCodeWithHyperLinks contents expr = pre_ $ go (1, 1) lines_ imports
    where
      imports = fragments expr
  
      lines_ = map fixWindows (Text.lines contents)
  
      fixWindows line
          | Text.null line         = line
          | Text.last line == '\r' = Text.init line
          | otherwise              = line
  
      -- we keep the current line, column and consumed text as part of function argument
      go :: (Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
      go _ textLines [] = mapM_ (\t -> toHtml t >> br_ []) textLines
  
      -- consume lines until we encounter the first 'SourceCodeFragment'
      go (currLineNumber, _) (currLine : restLines) scfs@((SourceCodeFragment Src {..} _) : _)
          | getSourceLine srcStart /= currLineNumber = do
              toHtml currLine
              br_ []
              go (currLineNumber + 1, 1) restLines scfs
  
      go (_, currCol) currentLines (scf@(SourceCodeFragment Src {..} _) : rest) = do
          let importStartLine = getSourceLine srcStart
          let importEndLine = getSourceLine srcEnd
  
          let importStartCol = getSourceColumn srcStart
          let importEndCol = getSourceColumn srcEnd
  
          let (importLines, suffixLines) = splitAt (importEndLine - importStartLine + 1) currentLines
  
          -- calls to `head` and `last` here should never fail since `importLines`
          -- have at least one element
          let (firstImportLine, lastImportLine) = (head importLines, last importLines)
          let prefixCols = Text.take (importStartCol - currCol) firstImportLine
          let suffixCols = Text.drop (importEndCol - currCol) lastImportLine
  
          -- render the prefix column
          toHtml prefixCols
  
          -- rendered element
          renderSourceCodeFragment scf
  
          -- add a newline if last line of import consumes the remaining line on
          -- the original text
          if Text.null suffixCols then br_ [] else return ()
  
          let suffix = if Text.null suffixCols then suffixLines else suffixCols : suffixLines
  
          -- move the cursor to next line if no characterse are remaining on the
          -- suffix cols, otherwise keep the last line and next char right after
          -- the import. This is done to handle properly several imports on the
          -- same line
          let nextPosition = if Text.null suffixCols then
                                 (importEndLine + 1, 1)
                             else (importEndLine, importEndCol)
  
          go nextPosition suffix rest
  
  -- | Internal utility to differentiate if a Dhall expr is a type annotation
  --   or the whole file
  data ExprType = TypeAnnotation | AssertionExample
  
  -- | Renders an AST /fragment/ from the source file AST. Use this when you don't
  --   have access to the 'Text' that was used to generate the AST.
  --   The difference between this and 'renderCodeWithHyperLinks' is that
  --   the extracted fragment's 'SourcePos's need to be re-generated to
  --   render them in a better way; just adding whitespace at the beginning of the
  --   first line won't render good results.
  renderCodeSnippet :: Dhall.Pretty.CharacterSet -> ExprType -> Expr Void Import -> Html ()
  renderCodeSnippet characterSet exprType expr = renderCodeWithHyperLinks formattedFile expr'
    where
      layout = case exprType of
          AssertionExample -> Dhall.Pretty.layout
          TypeAnnotation -> typeLayout
  
      formattedFile = Pretty.Text.renderStrict
          $ layout
          $ Dhall.Pretty.prettyCharacterSet characterSet (Core.denote expr)
  
      expr' = case Dhall.Parser.exprFromText "" formattedFile of
          Right e -> e
          Left _ -> fileAnIssue "A failure has occurred while parsing a formatted file"
  
      typeLayout = Pretty.removeTrailingWhitespace . Pretty.layoutSmart opts
        where
          -- this is done so the type of a dhall file fits in a single line
          -- its a safe value, since types in source codes are not that large
          opts = Pretty.defaultLayoutOptions
                  { Pretty.layoutPageWidth =
                      Pretty.Unbounded
                  }
  