{- | Prettyprint Giml

Convert Giml types, ast, and errors to text

-}

{-# language OverloadedStrings #-}

module Language.Giml.Pretty where

import Utils
import Language.Giml.Common
import Language.Giml.Types.Types
import Language.Giml.Syntax.Parser (SourcePos(..), unPos)
import Prettyprinter
import Prettyprinter.Render.Text (renderStrict)

-- * Print

render :: Doc a -> Text
render :: Doc a -> Text
render = SimpleDocStream a -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream a -> Text)
-> (Doc a -> SimpleDocStream a) -> Doc a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc a -> SimpleDocStream a
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions

printSourcePos :: SourcePos -> Text
printSourcePos :: SourcePos -> Text
printSourcePos = Doc Any -> Text
forall a. Doc a -> Text
render (Doc Any -> Text) -> (SourcePos -> Doc Any) -> SourcePos -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Doc Any
forall ann. SourcePos -> Doc ann
ppSourcePos

printType :: Type -> Text
printType :: Type -> Text
printType = Doc Any -> Text
forall a. Doc a -> Text
render (Doc Any -> Text) -> (Type -> Doc Any) -> Type -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc Any
forall ann. Type -> Doc ann
ppType

-- * Pretty Ann

ppSourcePos :: SourcePos -> Doc ann
ppSourcePos :: SourcePos -> Doc ann
ppSourcePos SourcePos
src =
  Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"" Doc ann
"" Doc ann
":"
    [ -- pretty $ sourceName src
      Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Doc ann) -> Int -> Doc ann
forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
src
    , Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Doc ann) -> Int -> Doc ann
forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
src
    ]

-- * Pretty Types

ppType :: Type -> Doc ann
ppType :: Type -> Doc ann
ppType = AddParens -> Type -> Doc ann
forall ann. AddParens -> Type -> Doc ann
ppType' AddParens
Nah

ppType' :: AddParens -> Type -> Doc ann
ppType' :: AddParens -> Type -> Doc ann
ppType' AddParens
addParens = \case
  TypeVar Text
t -> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t
  TypeCon Text
t -> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t
  TypeApp (TypeApp (TypeCon Text
"->") Type
t1) Type
t2 ->
    (if AddParens
Nah AddParens -> AddParens -> Bool
forall a. Eq a => a -> a -> Bool
/= AddParens
addParens then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens else Doc ann -> Doc ann
forall a. a -> a
id) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fun' [AddParens -> Type -> Doc ann
forall ann. AddParens -> Type -> Doc ann
ppType' AddParens
IfFunction Type
t1, AddParens -> Type -> Doc ann
forall ann. AddParens -> Type -> Doc ann
ppType' AddParens
Nah Type
t2]
  TypeApp Type
t1 Type
t2 ->
    (if AddParens
IfDatatype AddParens -> AddParens -> Bool
forall a. Eq a => a -> a -> Bool
== AddParens
addParens then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens else Doc ann -> Doc ann
forall a. a -> a
id) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ AddParens -> Type -> Doc ann
forall ann. AddParens -> Type -> Doc ann
ppType' AddParens
Nah Type
t1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AddParens -> Type -> Doc ann
forall ann. AddParens -> Type -> Doc ann
ppType' AddParens
IfDatatype Type
t2
  TypeRec [(Text, Type)]
record -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
record' ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Text, Type)] -> [Doc ann]
forall ann. [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
record
  TypeRecExt [(Text, Type)]
record Text
tv -> [Doc ann] -> Doc ann -> Doc ann
forall ann. [Doc ann] -> Doc ann -> Doc ann
recordAlt ([(Text, Type)] -> [Doc ann]
forall ann. [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
record) (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tv)
  TypeVariant [(Text, Type)]
vars -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
variant' ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Text, Type)] -> [Doc ann]
forall ann. [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
vars
  TypePolyVariantLB [(Text, Type)]
vars Text
tv -> [Doc ann] -> Doc ann -> Doc ann
forall ann. [Doc ann] -> Doc ann -> Doc ann
variantLB ([(Text, Type)] -> [Doc ann]
forall ann. [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
vars) (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tv)
  TypePolyVariantUB Text
tv [(Text, Type)]
vars -> [Doc ann] -> Doc ann -> Doc ann
forall ann. [Doc ann] -> Doc ann -> Doc ann
variantUB ([(Text, Type)] -> [Doc ann]
forall ann. [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
vars) (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tv)

data AddParens
  = Nah
  | IfFunction
  | IfDatatype
  deriving AddParens -> AddParens -> Bool
(AddParens -> AddParens -> Bool)
-> (AddParens -> AddParens -> Bool) -> Eq AddParens
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AddParens -> AddParens -> Bool
$c/= :: AddParens -> AddParens -> Bool
== :: AddParens -> AddParens -> Bool
$c== :: AddParens -> AddParens -> Bool
Eq

ppMapping :: [(Label, Type)] -> [Doc ann]
ppMapping :: [(Text, Type)] -> [Doc ann]
ppMapping [(Text, Type)]
record =
    ((Text, Type) -> Doc ann) -> [(Text, Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(Text
k, Type
v) -> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall ann. Type -> Doc ann
ppType Type
v)
      [(Text, Type)]
record

-- * Helpers

fun' :: [Doc ann] -> Doc ann
fun' :: [Doc ann] -> Doc ann
fun' = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"" Doc ann
"" Doc ann
" -> "

record' :: [Doc ann] -> Doc ann
record' :: [Doc ann] -> Doc ann
record' = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"{" Doc ann
"}" Doc ann
", "

recordAlt :: [Doc ann] -> Doc ann -> Doc ann
recordAlt :: [Doc ann] -> Doc ann -> Doc ann
recordAlt = Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
forall ann.
Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
encloseSepAlt Doc ann
"{" Doc ann
"}" Doc ann
", " (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
"| " Doc ann
" | ")

variant' :: [Doc ann] -> Doc ann
variant' :: [Doc ann] -> Doc ann
variant' = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"[" Doc ann
"]" Doc ann
" | "

-- we don't actually want to display the hidden variable but we'll do it for debugging purposes.
variantLB :: [Doc ann] -> Doc ann -> Doc ann
variantLB :: [Doc ann] -> Doc ann -> Doc ann
variantLB [Doc ann]
variants Doc ann
t
  | [Doc ann] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ann]
variants = Doc ann
t
  | Bool
otherwise = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"[>" Doc ann
"]" Doc ann
" | " [Doc ann]
variants
--  | otherwise = encloseSepAlt "[>" "]" " | " (flatAlt "| " " | ") variants ("(" <> t <> ")")

-- we don't actually want to display the hidden variable but we'll do it for debugging purposes.
variantUB :: [Doc ann] -> Doc ann -> Doc ann
variantUB :: [Doc ann] -> Doc ann -> Doc ann
variantUB [Doc ann]
variants Doc ann
_ = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"[<" Doc ann
"]" Doc ann
" | " [Doc ann]
variants
-- variantUB variants t = encloseSepAlt "[<" "]" " | " (flatAlt "| " " | ") variants ("(" <> t <> ")")

tupled' :: [Doc ann] -> Doc ann
tupled' :: [Doc ann] -> Doc ann
tupled' = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"(" Doc ann
")" Doc ann
", "

braced' :: [Doc ann] -> Doc ann
braced' :: [Doc ann] -> Doc ann
braced' = Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
"<" Doc ann
">" Doc ann
", "

encloseSep' :: Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' :: Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep' Doc ann
open Doc ann
close Doc ann
seperator =
  Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep
    (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
open Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" ") Doc ann
open)
    (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
close) Doc ann
close)
    Doc ann
seperator ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align

encloseSepAlt :: Doc ann -> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
encloseSepAlt :: Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
encloseSepAlt Doc ann
open Doc ann
close Doc ann
seperator Doc ann
lastsep [Doc ann]
elems Doc ann
lastelem =
  Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
forall ann.
Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
myEncloseSep
    (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
open Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" ") Doc ann
open)
    (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
close) Doc ann
close)
    Doc ann
seperator Doc ann
lastsep ((Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align [Doc ann]
elems) Doc ann
lastelem

myEncloseSep
    :: Doc ann   -- ^ left delimiter
    -> Doc ann   -- ^ right delimiter
    -> Doc ann   -- ^ separator
    -> Doc ann   -- ^ last separator
    -> [Doc ann] -- ^ input documents
    -> Doc ann   -- ^ last element
    -> Doc ann
myEncloseSep :: Doc ann
-> Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann -> Doc ann
myEncloseSep Doc ann
open Doc ann
close Doc ann
seperator Doc ann
lastsep [Doc ann]
ds Doc ann
lastelem =
  case [Doc ann]
ds of
    []  -> Doc ann
open Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
lastsep Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
lastelem Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
close
    [Doc ann
d] -> Doc ann
open Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
lastsep Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
lastelem Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
close
    [Doc ann]
_   -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
cat ((Doc ann -> Doc ann -> Doc ann)
-> [Doc ann] -> [Doc ann] -> [Doc ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(<>) (Doc ann
open Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Int -> Doc ann -> [Doc ann]
forall a. Int -> a -> [a]
replicate ([Doc ann] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc ann]
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Doc ann
seperator [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann
lastsep]) ([Doc ann]
ds [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann
lastelem])) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
close