{-# 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.Family                       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 -> Int
getSourceLine = Pos -> Int
SourcePos.unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
SourcePos.sourceLine
getSourceColumn :: SourcePos -> Int
getSourceColumn = Pos -> Int
SourcePos.unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
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 (JtdInfo -> JtdInfo -> Bool
(JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> Bool) -> Eq JtdInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JtdInfo -> JtdInfo -> Bool
== :: JtdInfo -> JtdInfo -> Bool
$c/= :: JtdInfo -> JtdInfo -> Bool
/= :: JtdInfo -> JtdInfo -> Bool
Eq, Eq JtdInfo
Eq JtdInfo =>
(JtdInfo -> JtdInfo -> Ordering)
-> (JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> JtdInfo)
-> (JtdInfo -> JtdInfo -> JtdInfo)
-> Ord JtdInfo
JtdInfo -> JtdInfo -> Bool
JtdInfo -> JtdInfo -> Ordering
JtdInfo -> JtdInfo -> JtdInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JtdInfo -> JtdInfo -> Ordering
compare :: JtdInfo -> JtdInfo -> Ordering
$c< :: JtdInfo -> JtdInfo -> Bool
< :: JtdInfo -> JtdInfo -> Bool
$c<= :: JtdInfo -> JtdInfo -> Bool
<= :: JtdInfo -> JtdInfo -> Bool
$c> :: JtdInfo -> JtdInfo -> Bool
> :: JtdInfo -> JtdInfo -> Bool
$c>= :: JtdInfo -> JtdInfo -> Bool
>= :: JtdInfo -> JtdInfo -> Bool
$cmax :: JtdInfo -> JtdInfo -> JtdInfo
max :: JtdInfo -> JtdInfo -> JtdInfo
$cmin :: JtdInfo -> JtdInfo -> JtdInfo
min :: JtdInfo -> JtdInfo -> JtdInfo
Ord, Int -> JtdInfo -> ShowS
[JtdInfo] -> ShowS
JtdInfo -> String
(Int -> JtdInfo -> ShowS)
-> (JtdInfo -> String) -> ([JtdInfo] -> ShowS) -> Show JtdInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JtdInfo -> ShowS
showsPrec :: Int -> JtdInfo -> ShowS
$cshow :: JtdInfo -> String
show :: JtdInfo -> String
$cshowList :: [JtdInfo] -> ShowS
showList :: [JtdInfo] -> ShowS
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 (NameDecl -> NameDecl -> Bool
(NameDecl -> NameDecl -> Bool)
-> (NameDecl -> NameDecl -> Bool) -> Eq NameDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameDecl -> NameDecl -> Bool
== :: NameDecl -> NameDecl -> Bool
$c/= :: NameDecl -> NameDecl -> Bool
/= :: NameDecl -> NameDecl -> Bool
Eq, Eq NameDecl
Eq NameDecl =>
(NameDecl -> NameDecl -> Ordering)
-> (NameDecl -> NameDecl -> Bool)
-> (NameDecl -> NameDecl -> Bool)
-> (NameDecl -> NameDecl -> Bool)
-> (NameDecl -> NameDecl -> Bool)
-> (NameDecl -> NameDecl -> NameDecl)
-> (NameDecl -> NameDecl -> NameDecl)
-> Ord NameDecl
NameDecl -> NameDecl -> Bool
NameDecl -> NameDecl -> Ordering
NameDecl -> NameDecl -> NameDecl
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NameDecl -> NameDecl -> Ordering
compare :: NameDecl -> NameDecl -> Ordering
$c< :: NameDecl -> NameDecl -> Bool
< :: NameDecl -> NameDecl -> Bool
$c<= :: NameDecl -> NameDecl -> Bool
<= :: NameDecl -> NameDecl -> Bool
$c> :: NameDecl -> NameDecl -> Bool
> :: NameDecl -> NameDecl -> Bool
$c>= :: NameDecl -> NameDecl -> Bool
>= :: NameDecl -> NameDecl -> Bool
$cmax :: NameDecl -> NameDecl -> NameDecl
max :: NameDecl -> NameDecl -> NameDecl
$cmin :: NameDecl -> NameDecl -> NameDecl
min :: NameDecl -> NameDecl -> NameDecl
Ord, Int -> NameDecl -> ShowS
[NameDecl] -> ShowS
NameDecl -> String
(Int -> NameDecl -> ShowS)
-> (NameDecl -> String) -> ([NameDecl] -> ShowS) -> Show NameDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameDecl -> ShowS
showsPrec :: Int -> NameDecl -> ShowS
$cshow :: NameDecl -> String
show :: NameDecl -> String
$cshowList :: [NameDecl] -> ShowS
showList :: [NameDecl] -> ShowS
Show)

makeHtmlId :: NameDecl -> Text
makeHtmlId :: NameDecl -> Text
makeHtmlId (NameDecl Src{SourcePos
srcStart :: SourcePos
srcStart :: Src -> SourcePos
srcStart} Text
_ JtdInfo
_) =
       Text
"var"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ SourcePos -> Int
getSourceLine SourcePos
srcStart) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ SourcePos -> Int
getSourceColumn SourcePos
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 :: Expr Src Import -> [SourceCodeFragment]
fragments = (SourceCodeFragment -> SourceCodeFragment -> Ordering)
-> [SourceCodeFragment] -> [SourceCodeFragment]
forall a. (a -> a -> Ordering) -> [a] -> [a]
Data.List.sortBy SourceCodeFragment -> SourceCodeFragment -> Ordering
sorter ([SourceCodeFragment] -> [SourceCodeFragment])
-> (Expr Src Import -> [SourceCodeFragment])
-> Expr Src Import
-> [SourceCodeFragment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SourceCodeFragment] -> [SourceCodeFragment]
removeUnusedDecls ([SourceCodeFragment] -> [SourceCodeFragment])
-> (Expr Src Import -> [SourceCodeFragment])
-> Expr Src Import
-> [SourceCodeFragment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer [SourceCodeFragment] JtdInfo -> [SourceCodeFragment]
forall w a. Writer w a -> w
Writer.execWriter (Writer [SourceCodeFragment] JtdInfo -> [SourceCodeFragment])
-> (Expr Src Import -> Writer [SourceCodeFragment] JtdInfo)
-> Expr Src Import
-> [SourceCodeFragment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
forall a. Context a
Context.empty
  where
    sorter :: SourceCodeFragment -> SourceCodeFragment -> Ordering
sorter (SourceCodeFragment Src{srcStart :: Src -> SourcePos
srcStart = SourcePos
srcStart0} SourceCodeType
_)
           (SourceCodeFragment Src{srcStart :: Src -> SourcePos
srcStart = SourcePos
srcStart1} SourceCodeType
_) = (Int, Int)
pos0 (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Int, Int)
pos1
      where
        pos0 :: (Int, Int)
pos0 = (SourcePos -> Int
getSourceLine SourcePos
srcStart0, SourcePos -> Int
getSourceColumn SourcePos
srcStart0)
        pos1 :: (Int, Int)
pos1 = (SourcePos -> Int
getSourceLine SourcePos
srcStart1, SourcePos -> Int
getSourceColumn SourcePos
srcStart1)

    removeUnusedDecls :: [SourceCodeFragment] -> [SourceCodeFragment]
removeUnusedDecls [SourceCodeFragment]
sourceCodeFragments = (SourceCodeFragment -> Bool)
-> [SourceCodeFragment] -> [SourceCodeFragment]
forall a. (a -> Bool) -> [a] -> [a]
filter SourceCodeFragment -> Bool
isUsed [SourceCodeFragment]
sourceCodeFragments
      where
        makePosPair :: Src -> (Int, Int)
makePosPair Src{SourcePos
srcStart :: Src -> SourcePos
srcStart :: SourcePos
srcStart} = (SourcePos -> Int
getSourceLine SourcePos
srcStart, SourcePos -> Int
getSourceColumn SourcePos
srcStart)
        nameUsePos :: SourceCodeFragment -> Maybe (Int, Int)
nameUsePos (SourceCodeFragment Src
_ (NameUse (NameDecl Src
src Text
_ JtdInfo
_))) =
            (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just ((Int, Int) -> Maybe (Int, Int)) -> (Int, Int) -> Maybe (Int, Int)
forall a b. (a -> b) -> a -> b
$ Src -> (Int, Int)
makePosPair Src
src
        nameUsePos SourceCodeFragment
_ = Maybe (Int, Int)
forall a. Maybe a
Nothing

        usedNames :: Set (Int, Int)
usedNames = [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Int, Int)] -> Set (Int, Int)) -> [(Int, Int)] -> Set (Int, Int)
forall a b. (a -> b) -> a -> b
$ (SourceCodeFragment -> Maybe (Int, Int))
-> [SourceCodeFragment] -> [(Int, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe SourceCodeFragment -> Maybe (Int, Int)
nameUsePos [SourceCodeFragment]
sourceCodeFragments

        isUsed :: SourceCodeFragment -> Bool
isUsed (SourceCodeFragment Src
_ (NameDeclaration (NameDecl Src
src Text
_ JtdInfo
_))) =
            Src -> (Int, Int)
makePosPair Src
src (Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Int, Int)
usedNames
        isUsed SourceCodeFragment
_ = Bool
True

    infer :: Context NameDecl -> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
    infer :: Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context = \case
        -- The parsed text of the import is located in it's `Note` constructor
        Note Src
src (Embed Import
a) -> [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
src (SourceCodeType -> SourceCodeFragment)
-> SourceCodeType -> SourceCodeFragment
forall a b. (a -> b) -> a -> b
$ Import -> SourceCodeType
ImportExpr Import
a] WriterT [SourceCodeFragment] Identity ()
-> Writer [SourceCodeFragment] JtdInfo
-> Writer [SourceCodeFragment] JtdInfo
forall a b.
WriterT [SourceCodeFragment] Identity a
-> WriterT [SourceCodeFragment] Identity b
-> WriterT [SourceCodeFragment] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
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 :: Src -> SourcePos
srcEnd = SourcePos
srcEnd0 })
                Text
name
                (Just Src { srcStart :: Src -> SourcePos
srcStart = SourcePos
srcStart1 })
                Maybe (Maybe Src, Expr Src Import)
annotation
                Maybe Src
_
                Expr Src Import
value) Expr Src Import
expr' -> do

            -- If annotation is missing, the type is inferred from the bound value
            case Maybe (Maybe Src, Expr Src Import)
annotation of
                Maybe (Maybe Src, Expr Src Import)
Nothing -> () -> WriterT [SourceCodeFragment] Identity ()
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just (Maybe Src
_, Expr Src Import
t) -> do
                    JtdInfo
_ <- Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
t
                    () -> WriterT [SourceCodeFragment] Identity ()
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            JtdInfo
bindingJtdInfo <- Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
value

            let nameSrc :: Src
nameSrc = SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
srcEnd0 SourcePos
srcStart1 Text
name
            let nameDecl :: NameDecl
nameDecl = Src -> Text -> JtdInfo -> NameDecl
NameDecl Src
nameSrc Text
name JtdInfo
bindingJtdInfo

            [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
nameSrc (NameDecl -> SourceCodeType
NameDeclaration NameDecl
nameDecl)]
            Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer (Text -> NameDecl -> Context NameDecl -> Context NameDecl
forall a. Text -> a -> Context a -> Context a
Context.insert Text
name NameDecl
nameDecl Context NameDecl
context) Expr Src Import
expr'

        Note Src
src (Var (V Text
name Int
index)) ->
            case Text -> Int -> Context NameDecl -> Maybe NameDecl
forall a. Text -> Int -> Context a -> Maybe a
Context.lookup Text
name Int
index Context NameDecl
context of
                Maybe NameDecl
Nothing -> JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo
                Just nameDecl :: NameDecl
nameDecl@(NameDecl Src
_ Text
_ JtdInfo
t) -> do
                    [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
src (SourceCodeType -> SourceCodeFragment)
-> SourceCodeType -> SourceCodeFragment
forall a b. (a -> b) -> a -> b
$ NameDecl -> SourceCodeType
NameUse NameDecl
nameDecl]
                    JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
t

        Lam Maybe CharacterSet
_ (FunctionBinding
                (Just Src{srcEnd :: Src -> SourcePos
srcEnd = SourcePos
srcEnd0})
                Text
name
                (Just Src{srcStart :: Src -> SourcePos
srcStart = SourcePos
srcStart1})
                Maybe Src
_
                Expr Src Import
t) Expr Src Import
expr -> do
            JtdInfo
dhallType <- Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
t

            let nameSrc :: Src
nameSrc = SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
srcEnd0 SourcePos
srcStart1 Text
name
            let nameDecl :: NameDecl
nameDecl = Src -> Text -> JtdInfo -> NameDecl
NameDecl Src
nameSrc Text
name JtdInfo
dhallType

            [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
nameSrc (NameDecl -> SourceCodeType
NameDeclaration NameDecl
nameDecl)]
            Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer (Text -> NameDecl -> Context NameDecl -> Context NameDecl
forall a. Text -> a -> Context a -> Context a
Context.insert Text
name NameDecl
nameDecl Context NameDecl
context) Expr Src Import
expr

        Field Expr Src Import
e (FieldSelection (Just Src{srcEnd :: Src -> SourcePos
srcEnd=SourcePos
posStart}) Text
label (Just Src{srcStart :: Src -> SourcePos
srcStart=SourcePos
posEnd})) -> do
            [NameDecl]
fields <- do
                JtdInfo
dhallType <- Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
e
                case JtdInfo
dhallType of
                    JtdInfo
NoInfo -> [NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl]
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [NameDecl]
forall a. Monoid a => a
mempty
                    RecordFields Set NameDecl
s -> [NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl]
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl])
-> [NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl]
forall a b. (a -> b) -> a -> b
$ Set NameDecl -> [NameDecl]
forall a. Set a -> [a]
Set.toList Set NameDecl
s

            let src :: Src
src = SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
posStart SourcePos
posEnd Text
label
            let match :: NameDecl -> Bool
match (NameDecl Src
_ Text
l JtdInfo
_) = Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
label
            case (NameDecl -> Bool) -> [NameDecl] -> [NameDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter NameDecl -> Bool
match [NameDecl]
fields of
                x :: NameDecl
x@(NameDecl Src
_ Text
_ JtdInfo
t) : [NameDecl]
_ -> do
                    [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
src (NameDecl -> SourceCodeType
NameUse NameDecl
x)]
                    JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
t
                [NameDecl]
_ -> JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo

        RecordLit (Map Text (RecordField Src Import)
-> [(Text, RecordField Src Import)]
forall k v. Ord k => Map k v -> [(k, v)]
Map.toList -> [(Text, RecordField Src Import)]
l) -> [(Text, RecordField Src Import)]
-> Writer [SourceCodeFragment] JtdInfo
forall {t :: * -> *}.
Traversable t =>
t (Text, RecordField Src Import)
-> Writer [SourceCodeFragment] JtdInfo
handleRecordLike [(Text, RecordField Src Import)]
l

        Record (Map Text (RecordField Src Import)
-> [(Text, RecordField Src Import)]
forall k v. Ord k => Map k v -> [(k, v)]
Map.toList -> [(Text, RecordField Src Import)]
l) -> [(Text, RecordField Src Import)]
-> Writer [SourceCodeFragment] JtdInfo
forall {t :: * -> *}.
Traversable t =>
t (Text, RecordField Src Import)
-> Writer [SourceCodeFragment] JtdInfo
handleRecordLike [(Text, RecordField Src Import)]
l

        Note Src
_ Expr Src Import
e -> Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
e
        Expr Src Import
e -> do
            (Expr Src Import -> Writer [SourceCodeFragment] JtdInfo)
-> [Expr Src Import] -> WriterT [SourceCodeFragment] Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context) ([Expr Src Import] -> WriterT [SourceCodeFragment] Identity ())
-> [Expr Src Import] -> WriterT [SourceCodeFragment] Identity ()
forall a b. (a -> b) -> a -> b
$ FoldLike
  [Expr Src Import]
  (Expr Src Import)
  (Expr Src Import)
  (Expr Src Import)
  (Expr Src Import)
-> Expr Src Import -> [Expr Src Import]
forall a s t b. FoldLike [a] s t a b -> s -> [a]
Lens.toListOf FoldLike
  [Expr Src Import]
  (Expr Src Import)
  (Expr Src Import)
  (Expr Src Import)
  (Expr Src Import)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Core.subExpressions Expr Src Import
e
            JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo

      where
        handleRecordLike :: t (Text, RecordField Src Import)
-> Writer [SourceCodeFragment] JtdInfo
handleRecordLike t (Text, RecordField Src Import)
l = Set NameDecl -> JtdInfo
RecordFields (Set NameDecl -> JtdInfo)
-> (t [NameDecl] -> Set NameDecl) -> t [NameDecl] -> JtdInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameDecl] -> Set NameDecl
forall a. Ord a => [a] -> Set a
Set.fromList ([NameDecl] -> Set NameDecl)
-> (t [NameDecl] -> [NameDecl]) -> t [NameDecl] -> Set NameDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t [NameDecl] -> [NameDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (t [NameDecl] -> JtdInfo)
-> WriterT [SourceCodeFragment] Identity (t [NameDecl])
-> Writer [SourceCodeFragment] JtdInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, RecordField Src Import)
 -> WriterT [SourceCodeFragment] Identity [NameDecl])
-> t (Text, RecordField Src Import)
-> WriterT [SourceCodeFragment] Identity (t [NameDecl])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (Text, RecordField Src Import)
-> WriterT [SourceCodeFragment] Identity [NameDecl]
f t (Text, RecordField Src Import)
l
          where
            f :: (Text, RecordField Src Import)
-> WriterT [SourceCodeFragment] Identity [NameDecl]
f (Text
key, RecordField (Just Src{srcEnd :: Src -> SourcePos
srcEnd = SourcePos
startPos}) Expr Src Import
val (Just Src{srcStart :: Src -> SourcePos
srcStart = SourcePos
endPos}) Maybe Src
_) = do
                JtdInfo
dhallType <- Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer Context NameDecl
context Expr Src Import
val
                let nameSrc :: Src
nameSrc = SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
startPos SourcePos
endPos Text
key
                let nameDecl :: NameDecl
nameDecl = Src -> Text -> JtdInfo -> NameDecl
NameDecl Src
nameSrc Text
key JtdInfo
dhallType
                [SourceCodeFragment] -> WriterT [SourceCodeFragment] Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
nameSrc (NameDecl -> SourceCodeType
NameDeclaration NameDecl
nameDecl)]
                [NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl]
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [ NameDecl
nameDecl ]
              where
            f (Text, RecordField Src Import)
_ = [NameDecl] -> WriterT [SourceCodeFragment] Identity [NameDecl]
forall a. a -> WriterT [SourceCodeFragment] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [ ]

fileAsText :: File -> Text
fileAsText :: File -> Text
fileAsText File{Text
Directory
directory :: Directory
file :: Text
directory :: File -> Directory
file :: File -> Text
..} = (Text -> Text -> Text) -> Text -> [Text] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
d Text
acc -> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d) Text
"" (Directory -> [Text]
Core.components Directory
directory)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 :: SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
srcStart SourcePos
srcEnd Text
name = Src {Text
SourcePos
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..}
  where
    realLength :: Int
realLength = SourcePos -> Int
getSourceColumn SourcePos
srcEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- SourcePos -> Int
getSourceColumn SourcePos
srcStart
    srcText :: Text
srcText =
        if Text -> Int
Text.length Text
name Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
realLength then Text
name
        else Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

renderSourceCodeFragment :: SourceCodeFragment -> Html ()
renderSourceCodeFragment :: SourceCodeFragment -> HtmlT Identity ()
renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcStart :: Src -> SourcePos
srcEnd :: Src -> SourcePos
srcText :: Src -> Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..} (ImportExpr Import
import_)) =
    Import -> Text -> HtmlT Identity ()
renderImport Import
import_ Text
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 -> Text -> HtmlT Identity ()
renderImport (Import {importHashed :: Import -> ImportHashed
importHashed = ImportHashed { ImportType
importType :: ImportType
importType :: ImportHashed -> ImportType
importType }}) =
        case ImportType
importType of
            Remote URL {Maybe Text
Maybe (Expr Src Import)
Text
Scheme
File
scheme :: Scheme
authority :: Text
path :: File
query :: Maybe Text
headers :: Maybe (Expr Src Import)
scheme :: URL -> Scheme
authority :: URL -> Text
path :: URL -> File
query :: URL -> Maybe Text
headers :: URL -> Maybe (Expr Src Import)
..} -> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href, Text -> Attribute
target_ Text
"_blank"] (HtmlT Identity () -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml
              where
                scheme_ :: Text
scheme_ = case Scheme
scheme of
                    Scheme
HTTP -> Text
"http"
                    Scheme
HTTPS -> Text
"https"

                path_ :: Text
path_ = File -> Text
fileAsText File
path

                query_ :: Text
query_ = case Maybe Text
query of
                    Maybe Text
Nothing -> Text
""
                    Just Text
d -> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d

                -- we don't include the headers here since we treat links to open a file
                -- in another tab
                href :: Text
href = Text
scheme_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
authority Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query_

            Local FilePrefix
Here File
file -> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href] (HtmlT Identity () -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml
              where
                href :: Text
href = Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> File -> Text
fileAsText File
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".html"

            Local FilePrefix
Parent File
file -> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href] (HtmlT Identity () -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml
              where
                href :: Text
href = Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> File -> Text
fileAsText File
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".html"

            ImportType
_ -> Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml

renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcStart :: Src -> SourcePos
srcEnd :: Src -> SourcePos
srcText :: Src -> Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..} (NameDeclaration NameDecl
nameDecl)) =
    [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Attribute]
attributes (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
srcText
  where
    attributes :: [Attribute]
attributes =
        [Text -> Attribute
id_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ NameDecl -> Text
makeHtmlId NameDecl
nameDecl
        , Text -> Attribute
class_ Text
"name-decl"
        , Text -> Text -> Attribute
data_ Text
"name" (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ NameDecl -> Text
makeHtmlId NameDecl
nameDecl ]
renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcStart :: Src -> SourcePos
srcEnd :: Src -> SourcePos
srcText :: Src -> Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..} (NameUse NameDecl
nameDecl)) =
    [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Attribute]
attributes (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
srcText
  where
    attributes :: [Attribute]
attributes =
        [ Text -> Attribute
href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameDecl -> Text
makeHtmlId NameDecl
nameDecl
        , Text -> Attribute
class_ Text
"name-use"
        , Text -> Text -> Attribute
data_ Text
"name" (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ NameDecl -> Text
makeHtmlId NameDecl
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 :: Text -> Expr Src Import -> HtmlT Identity ()
renderCodeWithHyperLinks Text
contents Expr Src Import
expr = HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
pre_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Text] -> [SourceCodeFragment] -> HtmlT Identity ()
go (Int
1, Int
1) [Text]
lines_ [SourceCodeFragment]
imports
  where
    imports :: [SourceCodeFragment]
imports = Expr Src Import -> [SourceCodeFragment]
fragments Expr Src Import
expr

    lines_ :: [Text]
lines_ = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
fixWindows (Text -> [Text]
Text.lines Text
contents)

    fixWindows :: Text -> Text
fixWindows Text
line
        | Text -> Bool
Text.null Text
line         = Text
line
        | HasCallStack => Text -> Char
Text -> Char
Text.last Text
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = HasCallStack => Text -> Text
Text -> Text
Text.init Text
line
        | Bool
otherwise              = Text
line

    -- we keep the current line, column and consumed text as part of function argument
    go :: (Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
    go :: (Int, Int) -> [Text] -> [SourceCodeFragment] -> HtmlT Identity ()
go (Int, Int)
_ [Text]
textLines [] = (Text -> HtmlT Identity ()) -> [Text] -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
t -> Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
t HtmlT Identity () -> HtmlT Identity () -> HtmlT Identity ()
forall a b.
HtmlT Identity a -> HtmlT Identity b -> HtmlT Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []) [Text]
textLines

    -- consume lines until we encounter the first 'SourceCodeFragment'
    go (Int
currLineNumber, Int
_) (Text
currLine : [Text]
restLines) scfs :: [SourceCodeFragment]
scfs@((SourceCodeFragment Src {Text
SourcePos
srcStart :: Src -> SourcePos
srcEnd :: Src -> SourcePos
srcText :: Src -> Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..} SourceCodeType
_) : [SourceCodeFragment]
_)
        | SourcePos -> Int
getSourceLine SourcePos
srcStart Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
currLineNumber = do
            Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
currLine
            [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
            (Int, Int) -> [Text] -> [SourceCodeFragment] -> HtmlT Identity ()
go (Int
currLineNumber Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
1) [Text]
restLines [SourceCodeFragment]
scfs

    go (Int
_, Int
currCol) [Text]
currentLines (scf :: SourceCodeFragment
scf@(SourceCodeFragment Src {Text
SourcePos
srcStart :: Src -> SourcePos
srcEnd :: Src -> SourcePos
srcText :: Src -> Text
srcStart :: SourcePos
srcEnd :: SourcePos
srcText :: Text
..} SourceCodeType
_) : [SourceCodeFragment]
rest) = do
        let importStartLine :: Int
importStartLine = SourcePos -> Int
getSourceLine SourcePos
srcStart
        let importEndLine :: Int
importEndLine = SourcePos -> Int
getSourceLine SourcePos
srcEnd

        let importStartCol :: Int
importStartCol = SourcePos -> Int
getSourceColumn SourcePos
srcStart
        let importEndCol :: Int
importEndCol = SourcePos -> Int
getSourceColumn SourcePos
srcEnd

        let ([Text]
importLines, [Text]
suffixLines) = Int -> [Text] -> ([Text], [Text])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
importEndLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
importStartLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
currentLines

        -- calls to `head` and `last` here should never fail since `importLines`
        -- have at least one element
        let (Text
firstImportLine, Text
lastImportLine) = ([Text] -> Text
forall a. HasCallStack => [a] -> a
head [Text]
importLines, [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
importLines)
        let prefixCols :: Text
prefixCols = Int -> Text -> Text
Text.take (Int
importStartCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currCol) Text
firstImportLine
        let suffixCols :: Text
suffixCols = Int -> Text -> Text
Text.drop (Int
importEndCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currCol) Text
lastImportLine

        -- render the prefix column
        Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
prefixCols

        -- rendered element
        SourceCodeFragment -> HtmlT Identity ()
renderSourceCodeFragment SourceCodeFragment
scf

        -- add a newline if last line of import consumes the remaining line on
        -- the original text
        if Text -> Bool
Text.null Text
suffixCols then [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ [] else () -> HtmlT Identity ()
forall a. a -> HtmlT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        let suffix :: [Text]
suffix = if Text -> Bool
Text.null Text
suffixCols then [Text]
suffixLines else Text
suffixCols Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
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 :: (Int, Int)
nextPosition = if Text -> Bool
Text.null Text
suffixCols then
                               (Int
importEndLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
1)
                           else (Int
importEndLine, Int
importEndCol)

        (Int, Int) -> [Text] -> [SourceCodeFragment] -> HtmlT Identity ()
go (Int, Int)
nextPosition [Text]
suffix [SourceCodeFragment]
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 Void Import -> HtmlT Identity ()
renderCodeSnippet CharacterSet
characterSet ExprType
exprType Expr Void Import
expr = Text -> Expr Src Import -> HtmlT Identity ()
renderCodeWithHyperLinks Text
formattedFile Expr Src Import
expr'
  where
    layout :: Doc ann -> SimpleDocStream ann
layout = case ExprType
exprType of
        ExprType
AssertionExample -> Doc ann -> SimpleDocStream ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout
        ExprType
TypeAnnotation -> Doc ann -> SimpleDocStream ann
forall ann. Doc ann -> SimpleDocStream ann
typeLayout

    formattedFile :: Text
formattedFile = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict
        (SimpleDocStream Ann -> Text) -> SimpleDocStream Ann -> Text
forall a b. (a -> b) -> a -> b
$ Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
layout
        (Doc Ann -> SimpleDocStream Ann) -> Doc Ann -> SimpleDocStream Ann
forall a b. (a -> b) -> a -> b
$ CharacterSet -> Expr Src Import -> Doc Ann
forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet (Expr Void Import -> Expr Src Import
forall s a t. Expr s a -> Expr t a
Core.denote Expr Void Import
expr)

    expr' :: Expr Src Import
expr' = case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText String
"" Text
formattedFile of
        Right Expr Src Import
e -> Expr Src Import
e
        Left ParseError
_ -> Text -> Expr Src Import
forall a. Text -> a
fileAnIssue Text
"A failure has occurred while parsing a formatted file"

    typeLayout :: Doc ann -> SimpleDocStream ann
typeLayout = SimpleDocStream ann -> SimpleDocStream ann
forall ann. SimpleDocStream ann -> SimpleDocStream ann
Pretty.removeTrailingWhitespace (SimpleDocStream ann -> SimpleDocStream ann)
-> (Doc ann -> SimpleDocStream ann)
-> Doc ann
-> SimpleDocStream ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
Pretty.layoutSmart LayoutOptions
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 :: LayoutOptions
opts = LayoutOptions
Pretty.defaultLayoutOptions
                { Pretty.layoutPageWidth =
                    Pretty.Unbounded
                }