{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
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.Maybe as Maybe
import qualified Data.List
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.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 Text.Megaparsec.Pos as SourcePos
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
data JtdInfo
= RecordFields (Set.Set NameDecl)
| NoInfo
deriving (JtdInfo -> JtdInfo -> Bool
(JtdInfo -> JtdInfo -> Bool)
-> (JtdInfo -> JtdInfo -> Bool) -> Eq JtdInfo
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
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
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
$cp1Ord :: Eq 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
showList :: [JtdInfo] -> ShowS
$cshowList :: [JtdInfo] -> ShowS
show :: JtdInfo -> String
$cshow :: JtdInfo -> String
showsPrec :: Int -> JtdInfo -> ShowS
$cshowsPrec :: Int -> JtdInfo -> ShowS
Show)
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
/= :: NameDecl -> NameDecl -> Bool
$c/= :: NameDecl -> NameDecl -> Bool
== :: NameDecl -> NameDecl -> Bool
$c== :: 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
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
$cp1Ord :: Eq 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
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"
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)
data SourceCodeType
= ImportExpr Import
| NameUse NameDecl
| NameDeclaration NameDecl
data SourceCodeFragment =
SourceCodeFragment
Src
SourceCodeType
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 :: 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
_))) =
(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
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JtdInfo -> Writer [SourceCodeFragment] JtdInfo
forall (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
NoInfo
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
case Maybe (Maybe Src, Expr Src Import)
annotation of
Maybe (Maybe Src, Expr Src Import)
Nothing -> () -> WriterT [SourceCodeFragment] Identity ()
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 (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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return JtdInfo
t
[NameDecl]
_ -> JtdInfo -> Writer [SourceCodeFragment] JtdInfo
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
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
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 (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 (Set NameDecl -> JtdInfo)
-> ([NameDecl] -> Set NameDecl) -> [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] -> JtdInfo)
-> WriterT [SourceCodeFragment] Identity [NameDecl]
-> Writer [SourceCodeFragment] JtdInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, RecordField Src Import)
-> WriterT [SourceCodeFragment] Identity NameDecl)
-> [(Text, RecordField Src Import)]
-> WriterT [SourceCodeFragment] Identity [NameDecl]
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
[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 (m :: * -> *) a. Monad m => a -> m a
return NameDecl
nameDecl
where
f (Text, RecordField Src Import)
_ = Text -> WriterT [SourceCodeFragment] Identity NameDecl
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
..} = (Text -> Text -> Text) -> Text -> [Text] -> Text
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
makeSrcForLabel
:: SourcePos
-> SourcePos
-> Text
-> Src
makeSrcForLabel :: SourcePos -> SourcePos -> Text -> Src
makeSrcForLabel SourcePos
srcStart SourcePos
srcEnd Text
name = Src :: SourcePos -> SourcePos -> Text -> Src
Src {Text
SourcePos
srcText :: Text
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcEnd :: SourcePos
srcStart :: SourcePos
..}
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 -> Html ()
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 -> Html ()
renderImport Import
import_ Text
srcText
where
renderImport :: Import -> Text -> Html ()
renderImport :: Import -> Text -> Html ()
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
..} -> [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href, Text -> Attribute
target_ Text
"_blank"] (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html ()
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
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d
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] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href] (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
href] (Html () -> Html ()) -> (Text -> Html ()) -> Text -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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 -> Html ()
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)) =
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
span_ [Attribute]
attributes (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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
srcText :: Text
srcEnd :: SourcePos
srcStart :: SourcePos
srcText :: Src -> Text
srcEnd :: Src -> SourcePos
srcStart :: Src -> SourcePos
..} (NameUse NameDecl
nameDecl)) =
[Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
a_ [Attribute]
attributes (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> 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
]
renderCodeWithHyperLinks :: Text -> Expr Src Import -> Html ()
renderCodeWithHyperLinks :: Text -> Expr Src Import -> Html ()
renderCodeWithHyperLinks Text
contents Expr Src Import
expr = Html () -> Html ()
forall arg result. Term arg result => arg -> result
pre_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
go (Int
1, Int
1) (Text -> [Text]
Text.lines Text
contents) [SourceCodeFragment]
imports
where
imports :: [SourceCodeFragment]
imports = Expr Src Import -> [SourceCodeFragment]
fragments Expr Src Import
expr
go :: (Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
go :: (Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
go (Int, Int)
_ [Text]
textLines [] = (Text -> Html ()) -> [Text] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
t -> Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t Html () -> Html () -> Html ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []) [Text]
textLines
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
currLineNumber = do
Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
currLine
[Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ []
(Int, Int) -> [Text] -> [SourceCodeFragment] -> Html ()
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
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) = 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
let (Text
firstImportLine, Text
lastImportLine) = ([Text] -> Text
forall a. [a] -> a
head [Text]
importLines, [Text] -> Text
forall a. [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
Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
prefixCols
SourceCodeFragment -> Html ()
renderSourceCodeFragment SourceCodeFragment
scf
if Text -> Bool
Text.null Text
suffixCols then [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
br_ [] else () -> Html ()
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
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] -> Html ()
go (Int, Int)
nextPosition [Text]
suffix [SourceCodeFragment]
rest
data ExprType = TypeAnnotation | AssertionExample
renderCodeSnippet :: Dhall.Pretty.CharacterSet -> ExprType -> Expr Void Import -> Html ()
renderCodeSnippet :: CharacterSet -> ExprType -> Expr Void Import -> Html ()
renderCodeSnippet CharacterSet
characterSet ExprType
exprType Expr Void Import
expr = Text -> Expr Src Import -> Html ()
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
opts :: LayoutOptions
opts = LayoutOptions
Pretty.defaultLayoutOptions
{ layoutPageWidth :: PageWidth
Pretty.layoutPageWidth =
PageWidth
Pretty.Unbounded
}