2018-02-14 23:31:54 +01:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2019-09-05 06:41:44 +02:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
|
2018-02-14 23:31:54 +01:00
|
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
|
|
|
2018-02-18 17:44:12 +01:00
|
|
|
{-| This module provides internal pretty-printing utilities which are used by
|
|
|
|
other modules but are not part of the public facing API
|
|
|
|
-}
|
|
|
|
|
2018-02-14 23:31:54 +01:00
|
|
|
module Dhall.Pretty.Internal (
|
2018-02-15 19:36:05 +01:00
|
|
|
Ann(..)
|
|
|
|
, annToAnsiStyle
|
|
|
|
, prettyExpr
|
2019-09-05 06:41:44 +02:00
|
|
|
, prettySrcExpr
|
2018-09-11 15:38:13 +02:00
|
|
|
|
|
|
|
, CharacterSet(..)
|
|
|
|
, prettyCharacterSet
|
|
|
|
|
2018-06-12 09:13:38 +02:00
|
|
|
, prettyVar
|
2018-02-14 23:31:54 +01:00
|
|
|
, pretty
|
|
|
|
, escapeText
|
Add concise types diffs to error messages (#336)
Fixes #207
This expands Dhall's error messages to include concise "type diffs"
whenever an actual type doesn't match an expected type. For example,
here is an example diff for some small changes to a very large (6,159
lines) type:
```
dhall <<< '../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall'
Use "dhall --explain" for detailed errors
Error: Expression doesn't match annotation
{ - license2 : …
, + license : …
, library : …
( ∀(… : { arch : ∀(… : < S390 : - Bool
+ {}
| …
>
)
→ …
, …
}
)
→ { build-tools : …
{ - version2 : …
, + version : …
, …
}
, default-extensions : …
< - NamedWildCards2 : …
| - UnboxedSums : …
| + DataKinds : …
| + NamedWildCards : …
| …
>
, …
}
)
, …
}
../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall
```
These type diffs are always emitted (i.e. present even if the user does
not supply the `--explain` flag).
2018-03-28 17:43:24 +02:00
|
|
|
|
|
|
|
, prettyConst
|
|
|
|
, prettyLabel
|
2019-03-30 19:50:26 +01:00
|
|
|
, prettyAnyLabel
|
2018-04-05 16:13:12 +02:00
|
|
|
, prettyLabels
|
Add concise types diffs to error messages (#336)
Fixes #207
This expands Dhall's error messages to include concise "type diffs"
whenever an actual type doesn't match an expected type. For example,
here is an example diff for some small changes to a very large (6,159
lines) type:
```
dhall <<< '../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall'
Use "dhall --explain" for detailed errors
Error: Expression doesn't match annotation
{ - license2 : …
, + license : …
, library : …
( ∀(… : { arch : ∀(… : < S390 : - Bool
+ {}
| …
>
)
→ …
, …
}
)
→ { build-tools : …
{ - version2 : …
, + version : …
, …
}
, default-extensions : …
< - NamedWildCards2 : …
| - UnboxedSums : …
| + DataKinds : …
| + NamedWildCards : …
| …
>
, …
}
)
, …
}
../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall
```
These type diffs are always emitted (i.e. present even if the user does
not supply the `--explain` flag).
2018-03-28 17:43:24 +02:00
|
|
|
, prettyNatural
|
|
|
|
, prettyNumber
|
2019-07-02 02:24:13 +02:00
|
|
|
, prettyInt
|
2018-11-21 00:07:08 +01:00
|
|
|
, prettyDouble
|
2018-06-12 09:13:38 +02:00
|
|
|
, prettyToStrictText
|
|
|
|
, prettyToString
|
|
|
|
|
|
|
|
, docToStrictText
|
Add concise types diffs to error messages (#336)
Fixes #207
This expands Dhall's error messages to include concise "type diffs"
whenever an actual type doesn't match an expected type. For example,
here is an example diff for some small changes to a very large (6,159
lines) type:
```
dhall <<< '../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall'
Use "dhall --explain" for detailed errors
Error: Expression doesn't match annotation
{ - license2 : …
, + license : …
, library : …
( ∀(… : { arch : ∀(… : < S390 : - Bool
+ {}
| …
>
)
→ …
, …
}
)
→ { build-tools : …
{ - version2 : …
, + version : …
, …
}
, default-extensions : …
< - NamedWildCards2 : …
| - UnboxedSums : …
| + DataKinds : …
| + NamedWildCards : …
| …
>
, …
}
)
, …
}
../dhall-to-cabal/dhall-to-cabal.dhall : ./type.dhall
```
These type diffs are always emitted (i.e. present even if the user does
not supply the `--explain` flag).
2018-03-28 17:43:24 +02:00
|
|
|
|
|
|
|
, builtin
|
|
|
|
, keyword
|
|
|
|
, literal
|
|
|
|
, operator
|
|
|
|
|
|
|
|
, colon
|
|
|
|
, comma
|
|
|
|
, dot
|
|
|
|
, equals
|
|
|
|
, forall
|
|
|
|
, label
|
|
|
|
, lambda
|
|
|
|
, langle
|
|
|
|
, lbrace
|
|
|
|
, lbracket
|
|
|
|
, lparen
|
|
|
|
, pipe
|
|
|
|
, rangle
|
|
|
|
, rarrow
|
|
|
|
, rbrace
|
|
|
|
, rbracket
|
|
|
|
, rparen
|
2018-02-14 23:31:54 +01:00
|
|
|
) where
|
|
|
|
|
2018-11-06 04:59:01 +01:00
|
|
|
import Dhall.Core
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
#if MIN_VERSION_base(4,8,0)
|
|
|
|
#else
|
|
|
|
import Control.Applicative (Applicative(..), (<$>))
|
|
|
|
#endif
|
|
|
|
import Data.Foldable
|
|
|
|
import Data.Monoid ((<>))
|
2018-06-01 19:54:07 +02:00
|
|
|
import Data.Text (Text)
|
2018-02-15 19:36:05 +01:00
|
|
|
import Data.Text.Prettyprint.Doc (Doc, Pretty, space)
|
2018-10-06 19:44:40 +02:00
|
|
|
import Dhall.Map (Map)
|
2018-11-06 04:59:01 +01:00
|
|
|
import Dhall.Set (Set)
|
2019-09-05 06:41:44 +02:00
|
|
|
import Dhall.Src (Src(..))
|
2018-02-14 23:31:54 +01:00
|
|
|
import Numeric.Natural (Natural)
|
|
|
|
import Prelude hiding (succ)
|
2018-02-15 19:36:05 +01:00
|
|
|
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
import qualified Data.Char
|
|
|
|
import qualified Data.HashSet
|
|
|
|
import qualified Data.List
|
2018-04-05 16:13:12 +02:00
|
|
|
import qualified Data.Set
|
2018-06-12 09:13:38 +02:00
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Text.Prettyprint.Doc as Pretty
|
|
|
|
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
|
|
|
import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty
|
2018-10-06 19:44:40 +02:00
|
|
|
import qualified Dhall.Map
|
2018-11-06 04:59:01 +01:00
|
|
|
import qualified Dhall.Set
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-02-18 17:44:12 +01:00
|
|
|
{-| Annotation type used to tag elements in a pretty-printed document for
|
|
|
|
syntax highlighting purposes
|
|
|
|
-}
|
2018-02-15 19:36:05 +01:00
|
|
|
data Ann
|
|
|
|
= Keyword -- ^ Used for syntactic keywords
|
|
|
|
| Syntax -- ^ Syntax punctuation such as commas, parenthesis, and braces
|
|
|
|
| Label -- ^ Record labels
|
|
|
|
| Literal -- ^ Literals such as integers and strings
|
|
|
|
| Builtin -- ^ Builtin types and values
|
2018-02-18 17:48:09 +01:00
|
|
|
| Operator -- ^ Operators
|
2018-02-15 19:36:05 +01:00
|
|
|
|
2018-02-18 17:44:12 +01:00
|
|
|
{-| Convert annotations to their corresponding color for syntax highlighting
|
|
|
|
purposes
|
|
|
|
-}
|
2018-02-15 19:36:05 +01:00
|
|
|
annToAnsiStyle :: Ann -> Terminal.AnsiStyle
|
2018-03-12 16:25:33 +01:00
|
|
|
annToAnsiStyle Keyword = Terminal.bold <> Terminal.colorDull Terminal.Green
|
|
|
|
annToAnsiStyle Syntax = Terminal.bold <> Terminal.colorDull Terminal.Green
|
2018-02-18 17:48:09 +01:00
|
|
|
annToAnsiStyle Label = mempty
|
|
|
|
annToAnsiStyle Literal = Terminal.colorDull Terminal.Magenta
|
|
|
|
annToAnsiStyle Builtin = Terminal.underlined
|
2018-03-12 16:25:33 +01:00
|
|
|
annToAnsiStyle Operator = Terminal.bold <> Terminal.colorDull Terminal.Green
|
2018-02-15 19:36:05 +01:00
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
data CharacterSet = ASCII | Unicode
|
|
|
|
|
2018-02-18 17:44:12 +01:00
|
|
|
-- | Pretty print an expression
|
2018-02-15 19:36:05 +01:00
|
|
|
prettyExpr :: Pretty a => Expr s a -> Doc Ann
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyExpr = prettySrcExpr . denote
|
|
|
|
|
|
|
|
prettySrcExpr :: Pretty a => Expr Src a -> Doc Ann
|
|
|
|
prettySrcExpr = prettyCharacterSet Unicode
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
{-| Internal utility for pretty-printing, used when generating element lists
|
|
|
|
to supply to `enclose` or `enclose'`. This utility indicates that the
|
|
|
|
compact represent is the same as the multi-line representation for each
|
|
|
|
element
|
|
|
|
-}
|
|
|
|
duplicate :: a -> (a, a)
|
|
|
|
duplicate x = (x, x)
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
isWhitespace :: Char -> Bool
|
|
|
|
isWhitespace c =
|
|
|
|
case c of
|
|
|
|
' ' -> True
|
|
|
|
'\n' -> True
|
|
|
|
'\t' -> True
|
|
|
|
'\r' -> True
|
|
|
|
_ -> False
|
|
|
|
|
|
|
|
{-| Used to render inline `Src` spans preserved by the syntax tree
|
|
|
|
|
|
|
|
>>> let unusedSourcePos = Text.Megaparsec.SourcePos "" (Text.Megaparsec.mkPos 1) (Text.Megaparsec.mkPos 1)
|
|
|
|
>>> let nonEmptySrc = Src unusedSourcePos unusedSourcePos "-- Documentation for x\n"
|
|
|
|
>>> "let" <> renderSrc (Just nonEmptySrc) " " <> "x = 1 in x"
|
|
|
|
let -- Documentation for x
|
|
|
|
x = 1 in x
|
|
|
|
>>> let emptySrc = Src unusedSourcePos unusedSourcePos " "
|
|
|
|
>>> "let" <> renderSrc (Just emptySrc) " " <> "x = 1 in x"
|
|
|
|
let x = 1 in x
|
|
|
|
>>> "let" <> renderSrc Nothing " " <> "x = 1 in x"
|
|
|
|
let x = 1 in x
|
|
|
|
-}
|
|
|
|
renderSrc
|
|
|
|
:: Maybe Src
|
|
|
|
-- ^ Source span to render (if present)
|
|
|
|
-> Doc Ann
|
|
|
|
-- ^ Used as the prefix (when the source span contains a comment) and as a
|
|
|
|
-- fallback (when the source span is absent or comment-free)
|
|
|
|
-> Doc Ann
|
|
|
|
renderSrc (Just (Src {..})) prefix
|
|
|
|
| not (Text.all isWhitespace srcText) =
|
|
|
|
prefix <> Pretty.align (Pretty.concatWith f newLines <> suffix)
|
|
|
|
where
|
|
|
|
horizontalSpace c = c == ' ' || c == '\t'
|
|
|
|
|
|
|
|
strippedText = Text.dropAround horizontalSpace srcText
|
|
|
|
|
|
|
|
suffix =
|
|
|
|
if Text.null strippedText
|
|
|
|
then mempty
|
|
|
|
else if Text.last strippedText == '\n' then mempty else " "
|
|
|
|
|
|
|
|
oldLines = Text.splitOn "\n" strippedText
|
|
|
|
|
|
|
|
spacePrefix = Text.takeWhile horizontalSpace
|
|
|
|
|
|
|
|
commonPrefix a b = case Text.commonPrefixes a b of
|
|
|
|
Nothing -> ""
|
|
|
|
Just (c, _, _) -> c
|
|
|
|
|
|
|
|
blank = Text.all horizontalSpace
|
|
|
|
|
|
|
|
newLines =
|
|
|
|
case oldLines of
|
|
|
|
[] ->
|
|
|
|
[]
|
|
|
|
l0 : [] ->
|
|
|
|
Pretty.pretty l0 : []
|
|
|
|
l0 : l1 : ls ->
|
|
|
|
let sharedPrefix =
|
|
|
|
foldl' commonPrefix (spacePrefix l1) (map spacePrefix (filter (not . blank) ls))
|
|
|
|
|
|
|
|
perLine l =
|
|
|
|
case Text.stripPrefix sharedPrefix l of
|
|
|
|
Nothing -> Pretty.pretty l
|
|
|
|
Just l' -> Pretty.pretty l'
|
|
|
|
|
|
|
|
in Pretty.pretty l0 : map perLine (l1 : ls)
|
|
|
|
|
|
|
|
f x y = x <> Pretty.hardline <> y
|
|
|
|
renderSrc _ prefix =
|
|
|
|
prefix
|
|
|
|
|
2018-02-15 19:36:05 +01:00
|
|
|
-- Annotation helpers
|
2018-02-18 17:48:09 +01:00
|
|
|
keyword, syntax, label, literal, builtin, operator :: Doc Ann -> Doc Ann
|
2018-02-15 19:36:05 +01:00
|
|
|
keyword = Pretty.annotate Keyword
|
|
|
|
syntax = Pretty.annotate Syntax
|
|
|
|
label = Pretty.annotate Label
|
|
|
|
literal = Pretty.annotate Literal
|
|
|
|
builtin = Pretty.annotate Builtin
|
2018-02-18 17:48:09 +01:00
|
|
|
operator = Pretty.annotate Operator
|
2018-02-15 19:36:05 +01:00
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
comma, lbracket, rbracket, langle, rangle, lbrace, rbrace, lparen, rparen, pipe, backtick, dollar, colon, equals, dot :: Doc Ann
|
2018-02-15 19:36:05 +01:00
|
|
|
comma = syntax Pretty.comma
|
|
|
|
lbracket = syntax Pretty.lbracket
|
|
|
|
rbracket = syntax Pretty.rbracket
|
|
|
|
langle = syntax Pretty.langle
|
|
|
|
rangle = syntax Pretty.rangle
|
|
|
|
lbrace = syntax Pretty.lbrace
|
|
|
|
rbrace = syntax Pretty.rbrace
|
|
|
|
lparen = syntax Pretty.lparen
|
|
|
|
rparen = syntax Pretty.rparen
|
|
|
|
pipe = syntax Pretty.pipe
|
|
|
|
backtick = syntax "`"
|
|
|
|
dollar = syntax "$"
|
|
|
|
colon = syntax ":"
|
|
|
|
equals = syntax "="
|
|
|
|
dot = syntax "."
|
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
lambda :: CharacterSet -> Doc Ann
|
|
|
|
lambda Unicode = syntax "λ"
|
|
|
|
lambda ASCII = syntax "\\"
|
|
|
|
|
|
|
|
forall :: CharacterSet -> Doc Ann
|
|
|
|
forall Unicode = syntax "∀"
|
|
|
|
forall ASCII = syntax "forall "
|
|
|
|
|
|
|
|
rarrow :: CharacterSet -> Doc Ann
|
|
|
|
rarrow Unicode = syntax "→"
|
|
|
|
rarrow ASCII = syntax "->"
|
|
|
|
|
2018-02-14 23:31:54 +01:00
|
|
|
-- | Pretty-print a list
|
2018-02-15 19:36:05 +01:00
|
|
|
list :: [Doc Ann] -> Doc Ann
|
|
|
|
list [] = lbracket <> rbracket
|
|
|
|
list docs =
|
|
|
|
enclose
|
|
|
|
(lbracket <> space)
|
|
|
|
(lbracket <> space)
|
|
|
|
(comma <> space)
|
|
|
|
(comma <> space)
|
|
|
|
(space <> rbracket)
|
|
|
|
rbracket
|
|
|
|
(fmap duplicate docs)
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
-- | Pretty-print union types and literals
|
2018-02-15 19:36:05 +01:00
|
|
|
angles :: [(Doc Ann, Doc Ann)] -> Doc Ann
|
|
|
|
angles [] = langle <> rangle
|
|
|
|
angles docs =
|
|
|
|
enclose
|
|
|
|
(langle <> space)
|
|
|
|
(langle <> space)
|
|
|
|
(space <> pipe <> space)
|
|
|
|
(pipe <> space)
|
|
|
|
(space <> rangle)
|
|
|
|
rangle
|
|
|
|
docs
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
-- | Pretty-print record types and literals
|
2018-02-15 19:36:05 +01:00
|
|
|
braces :: [(Doc Ann, Doc Ann)] -> Doc Ann
|
|
|
|
braces [] = lbrace <> rbrace
|
|
|
|
braces docs =
|
|
|
|
enclose
|
|
|
|
(lbrace <> space)
|
|
|
|
(lbrace <> space)
|
|
|
|
(comma <> space)
|
|
|
|
(comma <> space)
|
|
|
|
(space <> rbrace)
|
|
|
|
rbrace
|
|
|
|
docs
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
-- | Pretty-print anonymous functions and function types
|
2018-09-11 15:38:13 +02:00
|
|
|
arrows :: CharacterSet -> [(Doc Ann, Doc Ann)] -> Doc Ann
|
2019-02-27 20:32:48 +01:00
|
|
|
arrows ASCII =
|
|
|
|
enclose'
|
|
|
|
""
|
|
|
|
" "
|
|
|
|
(" " <> rarrow ASCII <> " ")
|
|
|
|
(rarrow ASCII <> " ")
|
|
|
|
arrows Unicode =
|
2018-02-15 19:36:05 +01:00
|
|
|
enclose'
|
|
|
|
""
|
|
|
|
" "
|
2019-02-27 20:32:48 +01:00
|
|
|
(" " <> rarrow Unicode <> " ")
|
|
|
|
(rarrow Unicode <> " ")
|
|
|
|
|
|
|
|
combine :: CharacterSet -> Text
|
|
|
|
combine ASCII = "/\\"
|
|
|
|
combine Unicode = "∧"
|
|
|
|
|
|
|
|
combineTypes :: CharacterSet -> Text
|
|
|
|
combineTypes ASCII = "//\\\\"
|
|
|
|
combineTypes Unicode = "⩓"
|
|
|
|
|
|
|
|
prefer :: CharacterSet -> Text
|
|
|
|
prefer ASCII = "//"
|
|
|
|
prefer Unicode = "⫽"
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-08-04 06:38:01 +02:00
|
|
|
equivalent :: CharacterSet -> Text
|
|
|
|
equivalent ASCII = "==="
|
|
|
|
equivalent Unicode = "≡"
|
|
|
|
|
2018-02-14 23:31:54 +01:00
|
|
|
{-| Format an expression that holds a variable number of elements, such as a
|
|
|
|
list, record, or union
|
|
|
|
-}
|
|
|
|
enclose
|
|
|
|
:: Doc ann
|
|
|
|
-- ^ Beginning document for compact representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Beginning document for multi-line representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Separator for compact representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Separator for multi-line representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Ending document for compact representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Ending document for multi-line representation
|
|
|
|
-> [(Doc ann, Doc ann)]
|
|
|
|
-- ^ Elements to format, each of which is a pair: @(compact, multi-line)@
|
|
|
|
-> Doc ann
|
|
|
|
enclose beginShort _ _ _ endShort _ [] =
|
|
|
|
beginShort <> endShort
|
|
|
|
where
|
|
|
|
enclose beginShort beginLong sepShort sepLong endShort endLong docs =
|
|
|
|
Pretty.group
|
|
|
|
(Pretty.flatAlt
|
|
|
|
(Pretty.align
|
|
|
|
(mconcat (zipWith combineLong (beginLong : repeat sepLong) docsLong) <> endLong)
|
|
|
|
)
|
|
|
|
(mconcat (zipWith combineShort (beginShort : repeat sepShort) docsShort) <> endShort)
|
|
|
|
)
|
|
|
|
where
|
|
|
|
docsShort = fmap fst docs
|
|
|
|
|
|
|
|
docsLong = fmap snd docs
|
|
|
|
|
|
|
|
combineLong x y = x <> y <> Pretty.hardline
|
|
|
|
|
|
|
|
combineShort x y = x <> y
|
|
|
|
|
|
|
|
{-| Format an expression that holds a variable number of elements without a
|
|
|
|
trailing document such as nested `let`, nested lambdas, or nested `forall`s
|
|
|
|
-}
|
|
|
|
enclose'
|
|
|
|
:: Doc ann
|
|
|
|
-- ^ Beginning document for compact representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Beginning document for multi-line representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Separator for compact representation
|
|
|
|
-> Doc ann
|
|
|
|
-- ^ Separator for multi-line representation
|
|
|
|
-> [(Doc ann, Doc ann)]
|
|
|
|
-- ^ Elements to format, each of which is a pair: @(compact, multi-line)@
|
|
|
|
-> Doc ann
|
|
|
|
enclose' beginShort beginLong sepShort sepLong docs =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
longLines = zipWith (<>) (beginLong : repeat sepLong) docsLong
|
|
|
|
|
|
|
|
long =
|
|
|
|
Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines))
|
|
|
|
|
|
|
|
short = mconcat (zipWith (<>) (beginShort : repeat sepShort) docsShort)
|
|
|
|
|
|
|
|
docsShort = fmap fst docs
|
|
|
|
|
|
|
|
docsLong = fmap snd docs
|
|
|
|
|
|
|
|
alpha :: Char -> Bool
|
|
|
|
alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A')
|
|
|
|
|
|
|
|
digit :: Char -> Bool
|
|
|
|
digit c = '\x30' <= c && c <= '\x39'
|
|
|
|
|
|
|
|
headCharacter :: Char -> Bool
|
|
|
|
headCharacter c = alpha c || c == '_'
|
|
|
|
|
|
|
|
tailCharacter :: Char -> Bool
|
|
|
|
tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/'
|
|
|
|
|
2019-03-30 19:50:26 +01:00
|
|
|
prettyLabelShared :: Bool -> Text -> Doc Ann
|
|
|
|
prettyLabelShared allowReserved a = label doc
|
2018-02-15 19:36:05 +01:00
|
|
|
where
|
|
|
|
doc =
|
|
|
|
case Text.uncons a of
|
|
|
|
Just (h, t)
|
2019-03-30 19:50:26 +01:00
|
|
|
| headCharacter h && Text.all tailCharacter t && (allowReserved || not (Data.HashSet.member a reservedIdentifiers))
|
2018-02-15 19:36:05 +01:00
|
|
|
-> Pretty.pretty a
|
|
|
|
_ -> backtick <> Pretty.pretty a <> backtick
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-03-30 19:50:26 +01:00
|
|
|
prettyLabel :: Text -> Doc Ann
|
|
|
|
prettyLabel = prettyLabelShared False
|
|
|
|
|
|
|
|
prettyAnyLabel :: Text -> Doc Ann
|
|
|
|
prettyAnyLabel = prettyLabelShared True
|
|
|
|
|
2018-04-05 16:13:12 +02:00
|
|
|
prettyLabels :: Set Text -> Doc Ann
|
|
|
|
prettyLabels a
|
2018-11-06 04:59:01 +01:00
|
|
|
| Data.Set.null (Dhall.Set.toSet a) =
|
2018-04-05 16:13:12 +02:00
|
|
|
lbrace <> rbrace
|
|
|
|
| otherwise =
|
2019-03-30 19:50:26 +01:00
|
|
|
braces (map (duplicate . prettyAnyLabel) (Dhall.Set.toList a))
|
2018-04-05 16:13:12 +02:00
|
|
|
|
2018-02-15 19:36:05 +01:00
|
|
|
prettyNumber :: Integer -> Doc Ann
|
|
|
|
prettyNumber = literal . Pretty.pretty
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-07-02 02:24:13 +02:00
|
|
|
prettyInt :: Int -> Doc Ann
|
|
|
|
prettyInt = literal . Pretty.pretty
|
|
|
|
|
2018-02-15 19:36:05 +01:00
|
|
|
prettyNatural :: Natural -> Doc Ann
|
|
|
|
prettyNatural = literal . Pretty.pretty
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-11-21 00:07:08 +01:00
|
|
|
prettyDouble :: Double -> Doc Ann
|
|
|
|
prettyDouble = literal . Pretty.pretty
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-02-15 19:36:05 +01:00
|
|
|
prettyConst :: Const -> Doc Ann
|
|
|
|
prettyConst Type = builtin "Type"
|
|
|
|
prettyConst Kind = builtin "Kind"
|
2018-10-15 18:22:21 +02:00
|
|
|
prettyConst Sort = builtin "Sort"
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-02-15 19:36:05 +01:00
|
|
|
prettyVar :: Var -> Doc Ann
|
|
|
|
prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x))
|
2019-07-02 02:24:13 +02:00
|
|
|
prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyInt n))
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-08-31 18:31:24 +02:00
|
|
|
{-| Pretty-print an 'Expr' using the given 'CharacterSet'.
|
|
|
|
|
|
|
|
'prettyCharacterSet' largely ignores 'Note's. 'Note's do however matter for
|
|
|
|
the layout of let-blocks:
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
>>> let inner = Let (Binding Nothing "x" Nothing Nothing Nothing (NaturalLit 1)) (Var (V "x" 0)) :: Expr Src ()
|
|
|
|
>>> prettyCharacterSet ASCII (Let (Binding Nothing "y" Nothing Nothing Nothing (NaturalLit 2)) inner)
|
2019-08-31 18:31:24 +02:00
|
|
|
let y = 2 let x = 1 in x
|
2019-09-05 06:41:44 +02:00
|
|
|
>>> prettyCharacterSet ASCII (Let (Binding Nothing "y" Nothing Nothing Nothing (NaturalLit 2)) (Note (Src unusedSourcePos unusedSourcePos "") inner))
|
2019-08-31 18:31:24 +02:00
|
|
|
let y = 2 in let x = 1 in x
|
|
|
|
|
|
|
|
This means the structure of parsed let-blocks is preserved.
|
|
|
|
-}
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyCharacterSet :: Pretty a => CharacterSet -> Expr Src a -> Doc Ann
|
2019-07-02 22:54:54 +02:00
|
|
|
prettyCharacterSet characterSet expression =
|
|
|
|
Pretty.group (prettyExpression expression)
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyExpression a0@(Lam _ _ _) =
|
|
|
|
arrows characterSet (fmap duplicate (docs a0))
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Lam a b c) = Pretty.group (Pretty.flatAlt long short) : docs c
|
|
|
|
where
|
|
|
|
long = (lambda characterSet <> space)
|
|
|
|
<> Pretty.align
|
|
|
|
( (lparen <> space)
|
|
|
|
<> prettyLabel a
|
|
|
|
<> Pretty.hardline
|
|
|
|
<> (colon <> space)
|
|
|
|
<> prettyExpression b
|
|
|
|
<> Pretty.hardline
|
|
|
|
<> rparen
|
|
|
|
)
|
|
|
|
|
|
|
|
short = (lambda characterSet <> lparen)
|
2018-02-14 23:31:54 +01:00
|
|
|
<> prettyLabel a
|
2018-09-11 15:38:13 +02:00
|
|
|
<> (space <> colon <> space)
|
2018-06-15 17:38:52 +02:00
|
|
|
<> prettyExpression b
|
2018-02-15 19:36:05 +01:00
|
|
|
<> rparen
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ c) = docs c
|
|
|
|
docs c = [ prettyExpression c ]
|
|
|
|
prettyExpression a0@(BoolIf _ _ _) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
prefixesLong =
|
|
|
|
" "
|
|
|
|
: cycle
|
|
|
|
[ Pretty.hardline <> keyword "then" <> " "
|
|
|
|
, Pretty.hardline <> keyword "else" <> " "
|
|
|
|
]
|
|
|
|
|
|
|
|
prefixesShort =
|
|
|
|
""
|
|
|
|
: cycle
|
|
|
|
[ space <> keyword "then" <> space
|
|
|
|
, space <> keyword "else" <> space
|
|
|
|
]
|
|
|
|
|
|
|
|
longLines = zipWith (<>) prefixesLong (docsLong a0)
|
|
|
|
|
|
|
|
long =
|
|
|
|
Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines))
|
|
|
|
|
|
|
|
short = mconcat (zipWith (<>) prefixesShort (docsShort a0))
|
|
|
|
|
|
|
|
docsLong (BoolIf a b c) =
|
|
|
|
docLong ++ docsLong c
|
|
|
|
where
|
|
|
|
docLong =
|
|
|
|
[ keyword "if" <> " " <> prettyExpression a
|
|
|
|
, prettyExpression b
|
2018-05-21 19:43:17 +02:00
|
|
|
]
|
2018-09-11 15:38:13 +02:00
|
|
|
docsLong (Note _ c) = docsLong c
|
|
|
|
docsLong c = [ prettyExpression c ]
|
|
|
|
|
|
|
|
docsShort (BoolIf a b c) =
|
|
|
|
docShort ++ docsShort c
|
|
|
|
where
|
|
|
|
docShort =
|
|
|
|
[ keyword "if" <> " " <> prettyExpression a
|
|
|
|
, prettyExpression b
|
2018-05-21 19:43:17 +02:00
|
|
|
]
|
2018-09-11 15:38:13 +02:00
|
|
|
docsShort (Note _ c) = docsShort c
|
|
|
|
docsShort c = [ prettyExpression c ]
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyExpression (Let a0 b0) =
|
2018-11-13 17:01:59 +01:00
|
|
|
enclose' "" "" space Pretty.hardline
|
|
|
|
(fmap duplicate (fmap docA (toList as)) ++ [ docB ])
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
2019-09-05 06:41:44 +02:00
|
|
|
MultiLet as b = multiLet a0 b0
|
2019-08-31 18:31:24 +02:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
docA (Binding src0 c src1 Nothing src2 e) =
|
2018-11-13 17:01:59 +01:00
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
|
|
|
long = keyword "let" <> space
|
|
|
|
<> Pretty.align
|
2019-09-05 06:41:44 +02:00
|
|
|
( renderSrc src0 mempty
|
|
|
|
<> prettyLabel c <> renderSrc src1 space
|
|
|
|
<> equals <> renderSrc src2 Pretty.hardline
|
|
|
|
<> " " <> prettyExpression e
|
2018-09-11 15:38:13 +02:00
|
|
|
)
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
short = keyword "let" <> renderSrc src0 space
|
|
|
|
<> prettyLabel c <> renderSrc src1 space
|
|
|
|
<> equals <> renderSrc src2 space
|
2018-11-13 17:01:59 +01:00
|
|
|
<> prettyExpression e
|
2019-09-05 06:41:44 +02:00
|
|
|
docA (Binding src0 c src1 (Just (src3, d)) src2 e) =
|
2018-11-13 17:01:59 +01:00
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
|
|
|
long = keyword "let" <> space
|
|
|
|
<> Pretty.align
|
2019-09-05 06:41:44 +02:00
|
|
|
( renderSrc src0 mempty
|
|
|
|
<> prettyLabel c <> renderSrc src1 Pretty.hardline
|
2019-09-11 07:21:11 +02:00
|
|
|
<> colon <> renderSrc src3 space <> prettyExpression d <> Pretty.hardline <> equals <> renderSrc src2 space
|
2018-11-13 17:01:59 +01:00
|
|
|
<> prettyExpression e
|
2018-09-11 15:38:13 +02:00
|
|
|
)
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
short = keyword "let" <> renderSrc src0 space
|
|
|
|
<> prettyLabel c <> renderSrc src1 space
|
|
|
|
<> colon <> renderSrc src3 space
|
|
|
|
<> prettyExpression d <> space <> equals <> renderSrc src2 space
|
2018-11-13 17:01:59 +01:00
|
|
|
<> prettyExpression e
|
|
|
|
|
|
|
|
docB =
|
|
|
|
( keyword "in" <> " " <> prettyExpression b
|
|
|
|
, keyword "in" <> " " <> prettyExpression b
|
|
|
|
)
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyExpression a0@(Pi _ _ _) =
|
|
|
|
arrows characterSet (fmap duplicate (docs a0))
|
2018-05-21 19:43:17 +02:00
|
|
|
where
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Pi "_" b c) = prettyOperatorExpression b : docs c
|
|
|
|
docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c
|
|
|
|
where
|
|
|
|
long = forall characterSet <> space
|
|
|
|
<> Pretty.align
|
|
|
|
( lparen <> space
|
|
|
|
<> prettyLabel a
|
|
|
|
<> Pretty.hardline
|
|
|
|
<> colon <> space
|
|
|
|
<> prettyExpression b
|
|
|
|
<> Pretty.hardline
|
|
|
|
<> rparen
|
|
|
|
)
|
|
|
|
|
|
|
|
short = forall characterSet <> lparen
|
|
|
|
<> prettyLabel a
|
|
|
|
<> space <> colon <> space
|
|
|
|
<> prettyExpression b
|
|
|
|
<> rparen
|
|
|
|
docs (Note _ c) = docs c
|
|
|
|
docs c = [ prettyExpression c ]
|
2019-08-04 06:38:01 +02:00
|
|
|
prettyExpression (Assert a) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
short = keyword "assert" <> " " <> colon <> " " <> prettyExpression a
|
|
|
|
|
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( " " <> keyword "assert"
|
|
|
|
<> Pretty.hardline <> colon <> " " <> prettyExpression a
|
|
|
|
)
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyExpression (Note _ a) =
|
|
|
|
prettyExpression a
|
|
|
|
prettyExpression a0 =
|
|
|
|
prettyAnnotatedExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyAnnotatedExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyAnnotatedExpression (Merge a b (Just c)) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
2018-09-11 15:38:13 +02:00
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( keyword "merge"
|
2018-02-14 23:31:54 +01:00
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression a)
|
2018-02-14 23:31:54 +01:00
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression b)
|
2018-02-14 23:31:54 +01:00
|
|
|
<> Pretty.hardline
|
2018-09-11 15:38:13 +02:00
|
|
|
<> colon <> space
|
|
|
|
<> prettyApplicationExpression c
|
2018-02-14 23:31:54 +01:00
|
|
|
)
|
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
short = keyword "merge" <> space
|
|
|
|
<> prettyImportExpression a
|
|
|
|
<> " "
|
|
|
|
<> prettyImportExpression b
|
2018-02-15 19:36:05 +01:00
|
|
|
<> space <> colon <> space
|
2018-09-11 15:38:13 +02:00
|
|
|
<> prettyApplicationExpression c
|
|
|
|
prettyAnnotatedExpression (Merge a b Nothing) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
2018-06-15 17:38:52 +02:00
|
|
|
where
|
2018-09-11 15:38:13 +02:00
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( keyword "merge"
|
2018-06-15 17:38:52 +02:00
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression a)
|
2018-06-15 17:38:52 +02:00
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression b)
|
2018-06-15 17:38:52 +02:00
|
|
|
)
|
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
short = keyword "merge" <> space
|
2018-06-15 17:38:52 +02:00
|
|
|
<> prettyImportExpression a
|
2018-09-11 15:38:13 +02:00
|
|
|
<> " "
|
2018-06-15 17:38:52 +02:00
|
|
|
<> prettyImportExpression b
|
2019-07-15 17:28:29 +02:00
|
|
|
prettyAnnotatedExpression (ToMap a (Just b)) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( keyword "toMap"
|
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression a)
|
2019-07-15 17:28:29 +02:00
|
|
|
<> Pretty.hardline
|
|
|
|
<> colon <> space
|
|
|
|
<> prettyApplicationExpression b
|
|
|
|
)
|
|
|
|
|
|
|
|
short = keyword "toMap" <> space
|
|
|
|
<> prettyImportExpression a
|
|
|
|
<> space <> colon <> space
|
|
|
|
<> prettyApplicationExpression b
|
|
|
|
prettyAnnotatedExpression (ToMap a Nothing) =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( keyword "toMap"
|
|
|
|
<> Pretty.hardline
|
2019-07-29 20:24:20 +02:00
|
|
|
<> Pretty.indent 2 (prettyImportExpression a)
|
2019-07-15 17:28:29 +02:00
|
|
|
)
|
|
|
|
|
|
|
|
short = keyword "toMap" <> space
|
|
|
|
<> prettyImportExpression a
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyAnnotatedExpression a0@(Annot _ _) =
|
|
|
|
enclose'
|
|
|
|
""
|
|
|
|
" "
|
|
|
|
(" " <> colon <> " ")
|
|
|
|
(colon <> space)
|
|
|
|
(fmap duplicate (docs a0))
|
|
|
|
where
|
|
|
|
docs (Annot a b) = prettyOperatorExpression a : docs b
|
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyExpression b ]
|
|
|
|
prettyAnnotatedExpression (ListLit (Just a) b) =
|
|
|
|
list (map prettyExpression (Data.Foldable.toList b))
|
|
|
|
<> " : "
|
2019-07-20 20:05:23 +02:00
|
|
|
<> prettyApplicationExpression a
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyAnnotatedExpression (Note _ a) =
|
|
|
|
prettyAnnotatedExpression a
|
|
|
|
prettyAnnotatedExpression a0 =
|
|
|
|
prettyOperatorExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyOperatorExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyOperatorExpression = prettyImportAltExpression
|
|
|
|
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator :: Text -> [Doc Ann] -> Doc Ann
|
|
|
|
prettyOperator op docs =
|
|
|
|
enclose'
|
|
|
|
""
|
|
|
|
prefix
|
|
|
|
(" " <> operator (Pretty.pretty op) <> " ")
|
|
|
|
(operator (Pretty.pretty op) <> spacer)
|
|
|
|
(reverse (fmap duplicate docs))
|
|
|
|
where
|
|
|
|
prefix = if Text.length op == 1 then " " else " "
|
|
|
|
|
|
|
|
spacer = if Text.length op == 1 then " " else " "
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyImportAltExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyImportAltExpression a0@(ImportAlt _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "?" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (ImportAlt a b) = prettyOrExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyOrExpression b ]
|
|
|
|
prettyImportAltExpression (Note _ a) =
|
|
|
|
prettyImportAltExpression a
|
|
|
|
prettyImportAltExpression a0 =
|
|
|
|
prettyOrExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyOrExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyOrExpression a0@(BoolOr _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "||" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (BoolOr a b) = prettyPlusExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyPlusExpression b ]
|
|
|
|
prettyOrExpression (Note _ a) =
|
|
|
|
prettyOrExpression a
|
|
|
|
prettyOrExpression a0 =
|
|
|
|
prettyPlusExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyPlusExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPlusExpression a0@(NaturalPlus _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "+" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (NaturalPlus a b) = prettyTextAppendExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyTextAppendExpression b ]
|
|
|
|
prettyPlusExpression (Note _ a) =
|
|
|
|
prettyPlusExpression a
|
|
|
|
prettyPlusExpression a0 =
|
|
|
|
prettyTextAppendExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyTextAppendExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyTextAppendExpression a0@(TextAppend _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "++" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (TextAppend a b) = prettyListAppendExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyListAppendExpression b ]
|
|
|
|
prettyTextAppendExpression (Note _ a) =
|
|
|
|
prettyTextAppendExpression a
|
|
|
|
prettyTextAppendExpression a0 =
|
|
|
|
prettyListAppendExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyListAppendExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyListAppendExpression a0@(ListAppend _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "#" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (ListAppend a b) = prettyAndExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyAndExpression b ]
|
|
|
|
prettyListAppendExpression (Note _ a) =
|
|
|
|
prettyListAppendExpression a
|
|
|
|
prettyListAppendExpression a0 =
|
|
|
|
prettyAndExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyAndExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyAndExpression a0@(BoolAnd _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "&&" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (BoolAnd a b) = prettyCombineExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyCombineExpression b ]
|
|
|
|
prettyAndExpression (Note _ a) =
|
|
|
|
prettyAndExpression a
|
|
|
|
prettyAndExpression a0 =
|
|
|
|
prettyCombineExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyCombineExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyCombineExpression a0@(Combine _ _) =
|
2019-02-27 20:32:48 +01:00
|
|
|
prettyOperator (combine characterSet) (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (Combine a b) = prettyPreferExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyPreferExpression b ]
|
|
|
|
prettyCombineExpression (Note _ a) =
|
|
|
|
prettyCombineExpression a
|
|
|
|
prettyCombineExpression a0 =
|
|
|
|
prettyPreferExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyPreferExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPreferExpression a0@(Prefer _ _) =
|
2019-02-27 20:32:48 +01:00
|
|
|
prettyOperator (prefer characterSet) (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (Prefer a b) = prettyCombineTypesExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyCombineTypesExpression b ]
|
|
|
|
prettyPreferExpression (Note _ a) =
|
|
|
|
prettyPreferExpression a
|
|
|
|
prettyPreferExpression a0 =
|
|
|
|
prettyCombineTypesExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyCombineTypesExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyCombineTypesExpression a0@(CombineTypes _ _) =
|
2019-02-27 20:32:48 +01:00
|
|
|
prettyOperator (combineTypes characterSet) (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (CombineTypes a b) = prettyTimesExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyTimesExpression b ]
|
|
|
|
prettyCombineTypesExpression (Note _ a) =
|
|
|
|
prettyCombineTypesExpression a
|
|
|
|
prettyCombineTypesExpression a0 =
|
|
|
|
prettyTimesExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyTimesExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyTimesExpression a0@(NaturalTimes _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "*" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (NaturalTimes a b) = prettyEqualExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyEqualExpression b ]
|
|
|
|
prettyTimesExpression (Note _ a) =
|
|
|
|
prettyTimesExpression a
|
|
|
|
prettyTimesExpression a0 =
|
|
|
|
prettyEqualExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyEqualExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyEqualExpression a0@(BoolEQ _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "==" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2018-09-20 17:43:42 +02:00
|
|
|
docs (BoolEQ a b) = prettyNotEqualExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyNotEqualExpression b ]
|
|
|
|
prettyEqualExpression (Note _ a) =
|
|
|
|
prettyEqualExpression a
|
|
|
|
prettyEqualExpression a0 =
|
|
|
|
prettyNotEqualExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyNotEqualExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyNotEqualExpression a0@(BoolNE _ _) =
|
2018-09-20 17:43:42 +02:00
|
|
|
prettyOperator "!=" (docs a0)
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2019-08-04 06:38:01 +02:00
|
|
|
docs (BoolNE a b) = prettyEquivalentExpression b : docs a
|
2018-09-11 15:38:13 +02:00
|
|
|
docs (Note _ b) = docs b
|
2019-08-04 06:38:01 +02:00
|
|
|
docs b = [ prettyEquivalentExpression b ]
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyNotEqualExpression (Note _ a) =
|
|
|
|
prettyNotEqualExpression a
|
|
|
|
prettyNotEqualExpression a0 =
|
2019-08-04 06:38:01 +02:00
|
|
|
prettyEquivalentExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyEquivalentExpression :: Pretty a => Expr Src a -> Doc Ann
|
2019-08-04 06:38:01 +02:00
|
|
|
prettyEquivalentExpression a0@(Equivalent _ _) =
|
|
|
|
prettyOperator (equivalent characterSet) (docs a0)
|
|
|
|
where
|
|
|
|
docs (Equivalent a b) = prettyApplicationExpression b : docs a
|
|
|
|
docs (Note _ b) = docs b
|
|
|
|
docs b = [ prettyApplicationExpression b ]
|
|
|
|
prettyEquivalentExpression (Note _ a) =
|
|
|
|
prettyEquivalentExpression a
|
|
|
|
prettyEquivalentExpression a0 =
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyApplicationExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyApplicationExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyApplicationExpression a0 = case a0 of
|
2019-02-28 06:44:36 +01:00
|
|
|
App _ _ -> result
|
|
|
|
Some _ -> result
|
|
|
|
Note _ b -> prettyApplicationExpression b
|
|
|
|
_ -> prettyImportExpression a0
|
2018-09-11 15:38:13 +02:00
|
|
|
where
|
2019-07-29 20:24:20 +02:00
|
|
|
result = enclose' "" "" " " "" (reverse (docs a0))
|
2018-09-11 15:38:13 +02:00
|
|
|
|
2019-07-29 20:24:20 +02:00
|
|
|
docs (App a b) = ( prettyImportExpression b, Pretty.indent 2 (prettyImportExpression b) ) : docs a
|
|
|
|
docs (Some a) = map duplicate [ prettyImportExpression a , builtin "Some" ]
|
2019-02-28 06:44:36 +01:00
|
|
|
docs (Note _ b) = docs b
|
2019-07-29 20:24:20 +02:00
|
|
|
docs b = map duplicate [ prettyImportExpression b ]
|
2018-09-11 15:38:13 +02:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyImportExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyImportExpression (Embed a) =
|
|
|
|
Pretty.pretty a
|
|
|
|
prettyImportExpression (Note _ a) =
|
|
|
|
prettyImportExpression a
|
|
|
|
prettyImportExpression a0 =
|
|
|
|
prettySelectorExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettySelectorExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettySelectorExpression (Field a b) =
|
2019-03-30 19:50:26 +01:00
|
|
|
prettySelectorExpression a <> dot <> prettyAnyLabel b
|
2019-05-28 05:54:42 +02:00
|
|
|
prettySelectorExpression (Project a (Left b)) =
|
2018-09-11 15:38:13 +02:00
|
|
|
prettySelectorExpression a <> dot <> prettyLabels b
|
2019-05-28 05:54:42 +02:00
|
|
|
prettySelectorExpression (Project a (Right b)) =
|
|
|
|
prettySelectorExpression a
|
|
|
|
<> dot
|
|
|
|
<> lparen
|
|
|
|
<> prettyExpression b
|
|
|
|
<> rparen
|
2018-09-11 15:38:13 +02:00
|
|
|
prettySelectorExpression (Note _ b) =
|
|
|
|
prettySelectorExpression b
|
|
|
|
prettySelectorExpression a0 =
|
|
|
|
prettyPrimitiveExpression a0
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyPrimitiveExpression :: Pretty a => Expr Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPrimitiveExpression (Var a) =
|
|
|
|
prettyVar a
|
|
|
|
prettyPrimitiveExpression (Const k) =
|
|
|
|
prettyConst k
|
|
|
|
prettyPrimitiveExpression Bool =
|
|
|
|
builtin "Bool"
|
|
|
|
prettyPrimitiveExpression Natural =
|
|
|
|
builtin "Natural"
|
|
|
|
prettyPrimitiveExpression NaturalFold =
|
|
|
|
builtin "Natural/fold"
|
|
|
|
prettyPrimitiveExpression NaturalBuild =
|
|
|
|
builtin "Natural/build"
|
|
|
|
prettyPrimitiveExpression NaturalIsZero =
|
|
|
|
builtin "Natural/isZero"
|
|
|
|
prettyPrimitiveExpression NaturalEven =
|
|
|
|
builtin "Natural/even"
|
|
|
|
prettyPrimitiveExpression NaturalOdd =
|
|
|
|
builtin "Natural/odd"
|
|
|
|
prettyPrimitiveExpression NaturalToInteger =
|
|
|
|
builtin "Natural/toInteger"
|
|
|
|
prettyPrimitiveExpression NaturalShow =
|
|
|
|
builtin "Natural/show"
|
2019-08-02 02:12:43 +02:00
|
|
|
prettyPrimitiveExpression NaturalSubtract =
|
|
|
|
builtin "Natural/subtract"
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPrimitiveExpression Integer =
|
|
|
|
builtin "Integer"
|
|
|
|
prettyPrimitiveExpression IntegerShow =
|
|
|
|
builtin "Integer/show"
|
|
|
|
prettyPrimitiveExpression IntegerToDouble =
|
|
|
|
builtin "Integer/toDouble"
|
|
|
|
prettyPrimitiveExpression Double =
|
|
|
|
builtin "Double"
|
|
|
|
prettyPrimitiveExpression DoubleShow =
|
|
|
|
builtin "Double/show"
|
|
|
|
prettyPrimitiveExpression Text =
|
|
|
|
builtin "Text"
|
2019-02-13 03:42:48 +01:00
|
|
|
prettyPrimitiveExpression TextShow =
|
|
|
|
builtin "Text/show"
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPrimitiveExpression List =
|
|
|
|
builtin "List"
|
|
|
|
prettyPrimitiveExpression ListBuild =
|
|
|
|
builtin "List/build"
|
|
|
|
prettyPrimitiveExpression ListFold =
|
|
|
|
builtin "List/fold"
|
|
|
|
prettyPrimitiveExpression ListLength =
|
|
|
|
builtin "List/length"
|
|
|
|
prettyPrimitiveExpression ListHead =
|
|
|
|
builtin "List/head"
|
|
|
|
prettyPrimitiveExpression ListLast =
|
|
|
|
builtin "List/last"
|
|
|
|
prettyPrimitiveExpression ListIndexed =
|
|
|
|
builtin "List/indexed"
|
|
|
|
prettyPrimitiveExpression ListReverse =
|
|
|
|
builtin "List/reverse"
|
|
|
|
prettyPrimitiveExpression Optional =
|
|
|
|
builtin "Optional"
|
|
|
|
prettyPrimitiveExpression None =
|
|
|
|
builtin "None"
|
|
|
|
prettyPrimitiveExpression OptionalFold =
|
|
|
|
builtin "Optional/fold"
|
|
|
|
prettyPrimitiveExpression OptionalBuild =
|
|
|
|
builtin "Optional/build"
|
|
|
|
prettyPrimitiveExpression (BoolLit True) =
|
|
|
|
builtin "True"
|
|
|
|
prettyPrimitiveExpression (BoolLit False) =
|
|
|
|
builtin "False"
|
|
|
|
prettyPrimitiveExpression (IntegerLit a)
|
|
|
|
| 0 <= a = literal "+" <> prettyNumber a
|
|
|
|
| otherwise = prettyNumber a
|
|
|
|
prettyPrimitiveExpression (NaturalLit a) =
|
|
|
|
prettyNatural a
|
2019-09-28 16:56:37 +02:00
|
|
|
prettyPrimitiveExpression (DoubleLit (DhallDouble a)) =
|
2018-11-21 00:07:08 +01:00
|
|
|
prettyDouble a
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyPrimitiveExpression (TextLit a) =
|
|
|
|
prettyChunks a
|
|
|
|
prettyPrimitiveExpression (Record a) =
|
|
|
|
prettyRecord a
|
|
|
|
prettyPrimitiveExpression (RecordLit a) =
|
|
|
|
prettyRecordLit a
|
|
|
|
prettyPrimitiveExpression (Union a) =
|
|
|
|
prettyUnion a
|
|
|
|
prettyPrimitiveExpression (ListLit Nothing b) =
|
|
|
|
list (map prettyExpression (Data.Foldable.toList b))
|
|
|
|
prettyPrimitiveExpression (Note _ b) =
|
|
|
|
prettyPrimitiveExpression b
|
|
|
|
prettyPrimitiveExpression a =
|
|
|
|
Pretty.group (Pretty.flatAlt long short)
|
|
|
|
where
|
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
(lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen)
|
|
|
|
|
|
|
|
short = lparen <> prettyExpression a <> rparen
|
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr Src a) -> (Doc Ann, Doc Ann)
|
2018-11-13 17:01:59 +01:00
|
|
|
prettyKeyValue separator (key, val) =
|
2019-09-14 16:10:29 +02:00
|
|
|
duplicate (Pretty.group (Pretty.flatAlt long short))
|
|
|
|
where
|
|
|
|
short = prettyAnyLabel key
|
2019-03-30 19:50:26 +01:00
|
|
|
<> " "
|
|
|
|
<> separator
|
|
|
|
<> " "
|
|
|
|
<> prettyExpression val
|
2019-09-14 16:10:29 +02:00
|
|
|
|
|
|
|
long = prettyAnyLabel key
|
2018-09-11 15:38:13 +02:00
|
|
|
<> " "
|
|
|
|
<> separator
|
2019-09-14 16:10:29 +02:00
|
|
|
<> Pretty.hardline
|
|
|
|
<> " "
|
|
|
|
<> prettyExpression val
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyRecord :: Pretty a => Map Text (Expr Src a) -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyRecord =
|
2018-10-06 19:44:40 +02:00
|
|
|
braces . map (prettyKeyValue colon) . Dhall.Map.toList
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyRecordLit :: Pretty a => Map Text (Expr Src a) -> Doc Ann
|
2018-02-14 23:31:54 +01:00
|
|
|
prettyRecordLit a
|
2018-10-06 19:44:40 +02:00
|
|
|
| Data.Foldable.null a =
|
2018-09-11 15:38:13 +02:00
|
|
|
lbrace <> equals <> rbrace
|
|
|
|
| otherwise
|
2018-10-06 19:44:40 +02:00
|
|
|
= braces (map (prettyKeyValue equals) (Dhall.Map.toList a))
|
2018-09-11 15:38:13 +02:00
|
|
|
|
2019-03-27 23:29:10 +01:00
|
|
|
prettyAlternative (key, Just val) = prettyKeyValue colon (key, val)
|
2019-03-30 19:50:26 +01:00
|
|
|
prettyAlternative (key, Nothing ) = duplicate (prettyAnyLabel key)
|
2019-03-27 23:29:10 +01:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyUnion :: Pretty a => Map Text (Maybe (Expr Src a)) -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyUnion =
|
2019-03-27 23:29:10 +01:00
|
|
|
angles . map prettyAlternative . Dhall.Map.toList
|
2018-09-11 15:38:13 +02:00
|
|
|
|
2019-09-05 06:41:44 +02:00
|
|
|
prettyChunks :: Pretty a => Chunks Src a -> Doc Ann
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyChunks (Chunks a b) =
|
|
|
|
if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b
|
|
|
|
then Pretty.flatAlt long short
|
|
|
|
else short
|
|
|
|
where
|
|
|
|
long =
|
|
|
|
Pretty.align
|
|
|
|
( literal ("''" <> Pretty.hardline)
|
|
|
|
<> Pretty.align
|
|
|
|
(foldMap prettyMultilineChunk a <> prettyMultilineBuilder b)
|
|
|
|
<> literal "''"
|
|
|
|
)
|
|
|
|
|
|
|
|
short =
|
|
|
|
literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"")
|
|
|
|
|
|
|
|
hasNewLine = Text.any (== '\n')
|
|
|
|
|
|
|
|
prettyMultilineChunk (c, d) =
|
|
|
|
prettyMultilineBuilder c
|
|
|
|
<> dollar
|
|
|
|
<> lbrace
|
|
|
|
<> prettyExpression d
|
|
|
|
<> rbrace
|
|
|
|
|
|
|
|
prettyMultilineBuilder builder = literal (mconcat docs)
|
|
|
|
where
|
|
|
|
lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder)
|
|
|
|
|
|
|
|
docs =
|
|
|
|
Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines)
|
|
|
|
|
|
|
|
prettyChunk (c, d) =
|
|
|
|
prettyText c
|
|
|
|
<> syntax "${"
|
|
|
|
<> prettyExpression d
|
|
|
|
<> syntax rbrace
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-09-11 15:38:13 +02:00
|
|
|
prettyText t = literal (Pretty.pretty (escapeText t))
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
-- | Pretty-print a value
|
|
|
|
pretty :: Pretty a => a -> Text
|
2018-06-01 19:54:07 +02:00
|
|
|
pretty = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
|
|
|
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
|
|
|
|
2018-06-01 19:54:07 +02:00
|
|
|
-- | Escape a `Text` literal using Dhall's escaping rules for single-quoted
|
2018-02-14 23:31:54 +01:00
|
|
|
-- @Text@
|
2018-06-01 19:54:07 +02:00
|
|
|
escapeSingleQuotedText :: Text -> Text
|
2018-02-14 23:31:54 +01:00
|
|
|
escapeSingleQuotedText inputBuilder = outputBuilder
|
|
|
|
where
|
2018-06-01 19:54:07 +02:00
|
|
|
outputText = substitute "${" "''${" (substitute "''" "'''" inputBuilder)
|
2018-02-14 23:31:54 +01:00
|
|
|
|
2018-06-01 19:54:07 +02:00
|
|
|
outputBuilder = outputText
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
substitute before after = Text.intercalate after . Text.splitOn before
|
|
|
|
|
2018-06-01 19:54:07 +02:00
|
|
|
{-| Escape a `Text` literal using Dhall's escaping rules
|
|
|
|
|
2018-02-18 17:44:12 +01:00
|
|
|
Note that the result does not include surrounding quotes
|
|
|
|
-}
|
2018-06-01 19:54:07 +02:00
|
|
|
escapeText :: Text -> Text
|
|
|
|
escapeText text = Text.concatMap adapt text
|
2018-02-14 23:31:54 +01:00
|
|
|
where
|
|
|
|
adapt c
|
2018-11-12 18:46:33 +01:00
|
|
|
| '\x20' <= c && c <= '\x21' = Text.singleton c
|
2018-02-14 23:31:54 +01:00
|
|
|
-- '\x22' == '"'
|
2018-11-12 18:46:33 +01:00
|
|
|
| '\x23' == c = Text.singleton c
|
2018-02-14 23:31:54 +01:00
|
|
|
-- '\x24' == '$'
|
2018-11-12 18:46:33 +01:00
|
|
|
| '\x25' <= c && c <= '\x5B' = Text.singleton c
|
2018-02-14 23:31:54 +01:00
|
|
|
-- '\x5C' == '\\'
|
2018-11-12 18:46:33 +01:00
|
|
|
| '\x5D' <= c && c <= '\x10FFFF' = Text.singleton c
|
|
|
|
| c == '"' = "\\\""
|
|
|
|
| c == '$' = "\\$"
|
|
|
|
| c == '\\' = "\\\\"
|
|
|
|
| c == '\b' = "\\b"
|
|
|
|
| c == '\f' = "\\f"
|
|
|
|
| c == '\n' = "\\n"
|
|
|
|
| c == '\r' = "\\r"
|
|
|
|
| c == '\t' = "\\t"
|
|
|
|
| otherwise = "\\u" <> showDigits (Data.Char.ord c)
|
2018-02-14 23:31:54 +01:00
|
|
|
|
|
|
|
showDigits r0 = Text.pack (map showDigit [q1, q2, q3, r3])
|
|
|
|
where
|
|
|
|
(q1, r1) = r0 `quotRem` 4096
|
|
|
|
(q2, r2) = r1 `quotRem` 256
|
|
|
|
(q3, r3) = r2 `quotRem` 16
|
|
|
|
|
|
|
|
showDigit n
|
|
|
|
| n < 10 = Data.Char.chr (Data.Char.ord '0' + n)
|
|
|
|
| otherwise = Data.Char.chr (Data.Char.ord 'A' + n - 10)
|
|
|
|
|
2018-06-12 09:13:38 +02:00
|
|
|
prettyToString :: Pretty a => a -> String
|
|
|
|
prettyToString =
|
|
|
|
Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty
|
|
|
|
where
|
|
|
|
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
|
|
|
|
|
|
|
docToStrictText :: Doc ann -> Text.Text
|
|
|
|
docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options
|
|
|
|
where
|
|
|
|
options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded }
|
|
|
|
|
|
|
|
prettyToStrictText :: Pretty a => a -> Text.Text
|
|
|
|
prettyToStrictText = docToStrictText . Pretty.pretty
|