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

makeHtmlId :: NameDecl -> Text
makeHtmlId :: NameDecl -> Text
makeHtmlId (NameDecl Src{SourcePos
srcStart :: Src -> SourcePos
srcStart :: SourcePos
srcStart} Text
_ JtdInfo
_) =
       Text
"var"
    forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ SourcePos -> Int
getSourceLine SourcePos
srcStart) forall a. Semigroup a => a -> a -> a
<> Text
"-"
    forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
Data.List.sortBy SourceCodeFragment -> SourceCodeFragment -> Ordering
sorter forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SourceCodeFragment] -> [SourceCodeFragment]
removeUnusedDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. Writer w a -> w
Writer.execWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context NameDecl
-> Expr Src Import -> Writer [SourceCodeFragment] JtdInfo
infer 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 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 = forall a. (a -> Bool) -> [a] -> [a]
filter SourceCodeFragment -> Bool
isUsed [SourceCodeFragment]
sourceCodeFragments
      where
        makePosPair :: Src -> (Int, Int)
makePosPair Src{SourcePos
srcStart :: SourcePos
srcStart :: Src -> 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
_))) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Src -> (Int, Int)
makePosPair Src
src
        nameUsePos SourceCodeFragment
_ = forall a. Maybe a
Nothing

        usedNames :: Set (Int, Int)
usedNames = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ 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 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) -> forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
src forall a b. (a -> b) -> a -> b
$ Import -> SourceCodeType
ImportExpr Import
a] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 -> 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
                    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

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

            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 (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
                    RecordFields Set NameDecl
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Text
label
            case forall a. (a -> Bool) -> [a] -> [a]
filter NameDecl -> Bool
match [NameDecl]
fields of
                x :: NameDecl
x@(NameDecl Src
_ Text
_ JtdInfo
t) : [NameDecl]
_ -> do
                    forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
src (NameDecl -> SourceCodeType
NameUse NameDecl
x)]
                    forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
t
                [NameDecl]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo

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

        Record (forall k v. Ord k => Map k v -> [(k, v)]
Map.toList -> [(Text, RecordField Src Import)]
l) -> [(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
            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) forall a b. (a -> b) -> a -> b
$ forall a s t b. FoldLike [a] s t a b -> s -> [a]
Lens.toListOf 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
            forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo

      where
        handleRecordLike :: [(Text, RecordField Src Import)]
-> Writer [SourceCodeFragment] JtdInfo
handleRecordLike [(Text, RecordField Src Import)]
l = Set NameDecl -> JtdInfo
RecordFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, RecordField Src Import)
-> WriterT [SourceCodeFragment] Identity NameDecl
f [(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
                forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell [Src -> SourceCodeType -> SourceCodeFragment
SourceCodeFragment Src
nameSrc (NameDecl -> SourceCodeType
NameDeclaration NameDecl
nameDecl)]
                forall (m :: * -> *) a. Monad m => a -> m a
return NameDecl
nameDecl
              where
            f (Text, RecordField Src Import)
_ = forall a. Text -> a
fileAnIssue Text
"A `RecordField` of type `Expr Src Import` doesn't have `Just src*`"

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

renderSourceCodeFragment :: SourceCodeFragment -> Html ()
renderSourceCodeFragment :: SourceCodeFragment -> HtmlT Identity ()
renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} (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 :: ImportHashed -> ImportType
importType :: ImportType
importType }}) =
        case ImportType
importType of
            Remote URL {Maybe Text
Maybe (Expr Src Import)
Text
File
Scheme
scheme :: URL -> Scheme
authority :: URL -> Text
path :: URL -> File
query :: URL -> Maybe Text
headers :: URL -> Maybe (Expr Src Import)
headers :: Maybe (Expr Src Import)
query :: Maybe Text
path :: File
authority :: Text
scheme :: Scheme
..} -> forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href, Text -> Attribute
target_ Text
"_blank"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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
"?" 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_ forall a. Semigroup a => a -> a -> a
<> Text
"://" forall a. Semigroup a => a -> a -> a
<> Text
authority forall a. Semigroup a => a -> a -> a
<> Text
path_ forall a. Semigroup a => a -> a -> a
<> Text
query_

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

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

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

renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} (NameDeclaration NameDecl
nameDecl)) =
    forall arg result. Term arg result => arg -> result
span_ [Attribute]
attributes forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
srcText
  where
    attributes :: [Attribute]
attributes =
        [Text -> Attribute
id_ forall a b. (a -> b) -> a -> b
$ NameDecl -> Text
makeHtmlId NameDecl
nameDecl
        , Text -> Attribute
class_ Text
"name-decl"
        , Text -> Text -> Attribute
data_ Text
"name" forall a b. (a -> b) -> a -> b
$ NameDecl -> Text
makeHtmlId NameDecl
nameDecl ]
renderSourceCodeFragment (SourceCodeFragment Src{Text
SourcePos
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} (NameUse NameDecl
nameDecl)) =
    forall arg result. Term arg result => arg -> result
a_ [Attribute]
attributes forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
srcText
  where
    attributes :: [Attribute]
attributes =
        [ Text -> Attribute
href_ forall a b. (a -> b) -> a -> b
$ 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" 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 = forall arg result. Term arg result => arg -> result
pre_ 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_ = 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
        | Text -> Char
Text.last Text
line forall a. Eq a => a -> a -> Bool
== Char
'\r' = 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 [] = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
t -> forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} SourceCodeType
_) : [SourceCodeFragment]
_)
        | SourcePos -> Int
getSourceLine SourcePos
srcStart forall a. Eq a => a -> a -> Bool
/= Int
currLineNumber = do
            forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
currLine
            forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
            (Int, Int) -> [Text] -> [SourceCodeFragment] -> HtmlT Identity ()
go (Int
currLineNumber 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
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} 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) = forall a. Int -> [a] -> ([a], [a])
splitAt (Int
importEndLine forall a. Num a => a -> a -> a
- Int
importStartLine 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) = (forall a. [a] -> a
head [Text]
importLines, forall a. [a] -> a
last [Text]
importLines)
        let prefixCols :: Text
prefixCols = Int -> Text -> Text
Text.take (Int
importStartCol forall a. Num a => a -> a -> a
- Int
currCol) Text
firstImportLine
        let suffixCols :: Text
suffixCols = Int -> Text -> Text
Text.drop (Int
importEndCol forall a. Num a => a -> a -> a
- Int
currCol) Text
lastImportLine

        -- render the prefix column
        forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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 forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ [] else 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 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 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 -> forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout
        ExprType
TypeAnnotation -> forall ann. Doc ann -> SimpleDocStream ann
typeLayout

    formattedFile :: Text
formattedFile = forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict
        forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> SimpleDocStream ann
layout
        forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet (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
_ -> forall a. Text -> a
fileAnIssue Text
"A failure has occurred while parsing a formatted file"

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