{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- We could avoid orphan instances by placing these PrettyPrec
-- instances in Swarm.Language.Syntax.AST, along with the declarations
-- of the types we are making PrettyPrec instances for, but the code
-- here depends nontrivially on stuff in other Swarm.Language.Syntax.*
-- modules, so that would require putting a whole bunch of stuff all
-- in the same module.  It seemed like a much better option to have
-- code split out into separate modules and disable orphan instance
-- warnings in this one.

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Pretty-printing for terms in the Swarm programming language.
module Swarm.Language.Syntax.Pretty (

) where

import Control.Lens ((&), (<>~))
import Control.Lens.Empty (pattern Empty)
import Data.Bool (bool)
import Data.Foldable qualified as F
import Data.Map qualified as M
import Data.Sequence qualified as Seq
import Data.String (fromString)
import Prettyprinter
import Swarm.Language.Syntax.AST
import Swarm.Language.Syntax.Comments
import Swarm.Language.Syntax.Constants
import Swarm.Language.Syntax.Loc
import Swarm.Language.Syntax.Pattern (sComments, pattern STerm)
import Swarm.Language.Syntax.Util (erase, unTuple)
import Swarm.Language.TDVar (TDVar)
import Swarm.Language.Types
import Swarm.Pretty (PrettyPrec (..), encloseWithIndent, pparens, ppr, prettyEquality)
import Text.Show.Unicode (ushow)

-- | Pretty-print a syntax node with comments.
instance PrettyPrec (Syntax' ty) where
  prettyPrec :: forall ann. Int -> Syntax' ty -> Doc ann
prettyPrec Int
p (Syntax' SrcLoc
_ Term' ty
t (Comments Seq Comment
before Seq Comment
after) ty
_) = case Seq Comment
before of
    Seq Comment
Empty -> Doc ann
forall {ann}. Doc ann
t'
    Seq Comment
_ ->
      -- Print out any comments before the node
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((Comment -> Doc ann) -> [Comment] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Seq Comment -> [Comment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Comment
before))
        , Doc ann
forall {ann}. Doc ann
hardline
        , Doc ann
forall {ann}. Doc ann
t'
        ]
   where
    -- Print the node itself, possibly with suffix comments on the same line
    t' :: Doc ann
t' = case Seq Comment -> ViewR Comment
forall a. Seq a -> ViewR a
Seq.viewr Seq Comment
after of
      ViewR Comment
Seq.EmptyR -> Int -> Term' ty -> Doc ann
forall ann. Int -> Term' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Term' ty
t
      Seq Comment
_ Seq.:> Comment
lst -> case Comment -> CommentType
commentType Comment
lst of
        -- Output a newline after a line comment, but not after a block comment
        CommentType
BlockComment -> Doc ann
forall {ann}. Doc ann
tWithComments
        CommentType
LineComment -> Doc ann
forall {ann}. Doc ann
tWithComments Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
hardline
     where
      -- The pretty-printed node with suffix comments
      tWithComments :: Doc ann
tWithComments = Int -> Term' ty -> Doc ann
forall ann. Int -> Term' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Term' ty
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Comment -> Doc ann) -> [Comment] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Seq Comment -> [Comment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Comment
after))

instance PrettyPrec (Term' ty) where
  prettyPrec :: forall ann. Int -> Term' ty -> Doc ann
prettyPrec Int
p = \case
    Term' ty
TUnit -> Doc ann
"()"
    TConst Const
c -> Int -> Const -> Doc ann
forall ann. Int -> Const -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
p Const
c
    TDir Direction
d -> Direction -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Direction
d
    TInt Integer
n -> Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
    TAntiInt Text
v -> Doc ann
"$int:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
v
    TText Text
s -> String -> Doc ann
forall a. IsString a => String -> a
fromString (Text -> String
forall a. Show a => a -> String
ushow Text
s)
    TAntiText Text
v -> Doc ann
"$str:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
v
    TAntiSyn Text
v -> Doc ann
"$syn:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
v
    TBool Bool
b -> Doc ann -> Doc ann -> Bool -> Doc ann
forall a. a -> a -> Bool -> a
bool Doc ann
"false" Doc ann
"true" Bool
b
    TRobot Int
r -> Doc ann
"<a" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
r Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
">"
    TRef Int
r -> Doc ann
"@" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
r
    TRequire Text
d -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"require" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term' Any -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Text -> Term' Any
forall ty. Text -> Term' ty
TText Text
d)
    TStock Int
n Text
e -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"stock" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Term' Any -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Text -> Term' Any
forall ty. Text -> Term' ty
TText Text
e)
    SRequirements Text
_ Syntax' ty
e -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"requirements" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
e
    TVar Text
s -> Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Text
s
    SDelay (Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_) -> Doc ann
"{}"
    SDelay Syntax' ty
t -> 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
. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
encloseWithIndent Int
2 Doc ann
forall {ann}. Doc ann
lbrace Doc ann
forall {ann}. Doc ann
rbrace (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t
    t :: Term' ty
t@SPair {} -> Term' ty -> Doc ann
forall ty a. Term' ty -> Doc a
prettyTuple Term' ty
t
    t :: Term' ty
t@SLam {} ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Term' ty -> Doc ann
forall ty a. Term' ty -> Doc a
prettyLambdas Term' ty
t
    -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3.
    -- Note a comment right after the operator will end up attached to
    -- the application of the operator to the first argument.
    SApp t :: Syntax' ty
t@(Syntax' SrcLoc
_ (SApp op :: Syntax' ty
op@(Syntax' SrcLoc
_ (TConst Const
c) Comments
_ ty
_) Syntax' ty
l) Comments
opcom ty
_) Syntax' ty
r ->
      let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
          pC :: Int
pC = ConstInfo -> Int
fixity ConstInfo
ci
       in case ConstInfo -> ConstMeta
constMeta ConstInfo
ci of
            ConstMBinOp MBinAssoc
assoc ->
              Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (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
hsep
                  [ Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc MBinAssoc -> MBinAssoc -> Bool
forall a. Eq a => a -> a -> Bool
== MBinAssoc
R)) Syntax' ty
l
                  , -- pretty-print the operator with comments reattached
                    Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr (Syntax' ty
op {_sComments = opcom})
                  , Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int
pC Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (MBinAssoc
assoc MBinAssoc -> MBinAssoc -> Bool
forall a. Eq a => a -> a -> Bool
== MBinAssoc
L)) Syntax' ty
r
                  ]
            ConstMeta
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t Syntax' ty
r
    SApp Syntax' ty
t1 Syntax' ty
t2 -> case Syntax' ty
t1 of
      Syntax' SrcLoc
_ (TConst Const
c) Comments
_ ty
_ ->
        let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
            pC :: Int
pC = ConstInfo -> Int
fixity ConstInfo
ci
         in case ConstInfo -> ConstMeta
constMeta ConstInfo
ci of
              ConstMUnOp MUnAssoc
P -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int -> Int
forall a. Enum a => a -> a
succ Int
pC) Syntax' ty
t2
              ConstMUnOp MUnAssoc
S -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pC) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec (Int -> Int
forall a. Enum a => a -> a
succ Int
pC) Syntax' ty
t2 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1
              ConstMeta
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2
      Syntax' ty
_ -> Int -> Syntax' ty -> Syntax' ty -> Doc ann
forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2
    SLet LetSyntax
LSLet Bool
_ (LV SrcLoc
_ Text
x) Maybe RawPolytype
mty Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep
        [ Doc ann -> Text -> Maybe RawPolytype -> Syntax' ty -> Doc ann
forall ann (q :: ImplicitQuantification) ty.
Doc ann -> Text -> Maybe (Poly q Type) -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
"let" Text
x Maybe RawPolytype
mty Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"in"
        , Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t2
        ]
    SLet LetSyntax
LSDef Bool
_ (LV SrcLoc
_ Text
x) Maybe RawPolytype
mty Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([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
sep [Doc ann -> Text -> Maybe RawPolytype -> Syntax' ty -> Doc ann
forall ann (q :: ImplicitQuantification) ty.
Doc ann -> Text -> Maybe (Poly q Type) -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
"def" Text
x Maybe RawPolytype
mty Syntax' ty
t1, Doc ann
"end"]
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: case Syntax' ty
t2 of
            Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_ -> []
            Syntax' ty
_ -> [Doc ann
forall {ann}. Doc ann
hardline, Doc ann
forall {ann}. Doc ann
hardline, Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t2]
    STydef (LV SrcLoc
_ TDVar
x) Polytype
pty Maybe TydefInfo
_ Syntax' ty
t1 ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        TDVar -> Polytype -> Doc ann
forall ann. TDVar -> Polytype -> Doc ann
prettyTydef TDVar
x Polytype
pty
          Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: case Syntax' ty
t1 of
            Syntax' SrcLoc
_ (TConst Const
Noop) Comments
_ ty
_ -> []
            Syntax' ty
_ -> [Doc ann
forall {ann}. Doc ann
hardline, Doc ann
forall {ann}. Doc ann
hardline, Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t1]
    SBind Maybe (Located Text)
Nothing Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Syntax' ty
t2
    SBind (Just (LV SrcLoc
_ Text
x)) Maybe ty
_ Maybe Polytype
_ Maybe Requirements
_ Syntax' ty
t1 Syntax' ty
t2 ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Text
x 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
<+> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
0 Syntax' ty
t2
    SRcd Map Text (Maybe (Syntax' ty))
m -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (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
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((Text, Maybe (Syntax' ty)) -> Doc ann)
-> [(Text, Maybe (Syntax' ty))] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe (Syntax' ty)) -> Doc ann
forall a b ann.
(PrettyPrec a, PrettyPrec b) =>
(a, Maybe b) -> Doc ann
prettyEquality (Map Text (Maybe (Syntax' ty)) -> [(Text, Maybe (Syntax' ty))]
forall k a. Map k a -> [(k, a)]
M.assocs Map Text (Maybe (Syntax' ty))
m)))
    SProj Syntax' ty
t Text
x -> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Text
x
    SAnnotate Syntax' ty
t RawPolytype
pt ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
1 Syntax' ty
t 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
<+> RawPolytype -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr RawPolytype
pt
    SSuspend Syntax' ty
t ->
      Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        Doc ann
"suspend" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Syntax' ty -> Doc ann
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t
    SParens Syntax' ty
t -> Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
pparens Bool
True (Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
t)
    TType Type
ty -> Doc ann
"@" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Type -> Doc ann
forall ann. Int -> Type -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Type
ty

prettyDefinition :: Doc ann -> Var -> Maybe (Poly q Type) -> Syntax' ty -> Doc ann
prettyDefinition :: forall ann (q :: ImplicitQuantification) ty.
Doc ann -> Text -> Maybe (Poly q Type) -> Syntax' ty -> Doc ann
prettyDefinition Doc ann
defName Text
x Maybe (Poly q Type)
mty Syntax' ty
t1 =
  Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (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
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
    [ Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt
        (Doc ann
defHead Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group Doc ann
forall {ann}. Doc ann
defType Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall {ann}. Doc ann
eqAndLambdaLine)
        (Doc ann
defHead Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group Doc ann
forall {ann}. Doc ann
defType' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall {ann}. Doc ann
defEqLambdas)
    , Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ty
defBody
    ]
 where
  (Syntax' ty
defBody, [(Text, Maybe Type)]
defLambdaList) = Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
unchainLambdas Syntax' ty
t1
  defHead :: Doc ann
defHead = Doc ann
defName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Text
x
  defType :: Doc ann
defType = Doc ann
-> (Poly q Type -> Doc ann) -> Maybe (Poly q Type) -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" (\Poly q Type
ty -> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Doc ann
forall {ann}. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Poly q Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Poly q Type
ty)) (Poly q Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Poly q Type
ty)) Maybe (Poly q Type)
mty
  defType' :: Doc ann
defType' = Doc ann
-> (Poly q Type -> Doc ann) -> Maybe (Poly q Type) -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" (\Poly q Type
ty -> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Poly q Type -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr Poly q Type
ty) Maybe (Poly q Type)
mty
  defEqLambdas :: Doc ann
defEqLambdas = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann
"=" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((Text, Maybe Type) -> Doc ann)
-> [(Text, Maybe Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Type) -> Doc ann
forall a b ann.
(PrettyPrec a, PrettyPrec b) =>
(a, Maybe b) -> Doc ann
prettyLambda [(Text, Maybe Type)]
defLambdaList)
  eqAndLambdaLine :: Doc ann
eqAndLambdaLine = if [(Text, Maybe Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Maybe Type)]
defLambdaList then Doc ann
"=" else Doc ann
forall {ann}. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall {ann}. Doc ann
defEqLambdas

prettyTydef :: TDVar -> Polytype -> Doc ann
prettyTydef :: forall ann. TDVar -> Polytype -> Doc ann
prettyTydef TDVar
x (Polytype -> ([Text], Type)
forall t. Poly 'Quantified t -> ([Text], t)
unPoly -> ([], Type
ty)) = Doc ann
"tydef" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TDVar -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TDVar
x 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 a ann. PrettyPrec a => a -> Doc ann
ppr Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end"
prettyTydef TDVar
x (Polytype -> ([Text], Type)
forall t. Poly 'Quantified t -> ([Text], t)
unPoly -> ([Text]
xs, Type
ty)) = Doc ann
"tydef" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TDVar -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr TDVar
x Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr [Text]
xs) 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 a ann. PrettyPrec a => a -> Doc ann
ppr Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end"

prettyPrecApp :: Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp :: forall ty a. Int -> Syntax' ty -> Syntax' ty -> Doc a
prettyPrecApp Int
p Syntax' ty
t1 Syntax' ty
t2 =
  Bool -> Doc a -> Doc a
forall ann. Bool -> Doc ann -> Doc ann
pparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$
    Int -> Syntax' ty -> Doc a
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
10 Syntax' ty
t1 Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Syntax' ty -> Doc a
forall ann. Int -> Syntax' ty -> Doc ann
forall a ann. PrettyPrec a => Int -> a -> Doc ann
prettyPrec Int
11 Syntax' ty
t2

prettyTuple :: Term' ty -> Doc a
prettyTuple :: forall ty a. Term' ty -> Doc a
prettyTuple = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
tupled ([Doc a] -> Doc a) -> (Term' ty -> [Doc a]) -> Term' ty -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Syntax' () -> Doc a) -> [Syntax' ()] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Syntax' () -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr ([Syntax' ()] -> [Doc a])
-> (Term' ty -> [Syntax' ()]) -> Term' ty -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Syntax' () -> [Syntax' ()]
forall ty. Syntax' ty -> [Syntax' ty]
unTuple (Syntax' () -> [Syntax' ()])
-> (Term' ty -> Syntax' ()) -> Term' ty -> [Syntax' ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Syntax' ()
STerm (Term -> Syntax' ())
-> (Term' ty -> Term) -> Term' ty -> Syntax' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term' ty -> Term
forall (t :: * -> *) ty. Functor t => t ty -> t ()
erase

prettyLambdas :: Term' ty -> Doc a
prettyLambdas :: forall ty a. Term' ty -> Doc a
prettyLambdas Term' ty
t = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
hsep ((Text, Maybe Type) -> Doc a
forall a b ann.
(PrettyPrec a, PrettyPrec b) =>
(a, Maybe b) -> Doc ann
prettyLambda ((Text, Maybe Type) -> Doc a) -> [(Text, Maybe Type)] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Maybe Type)]
lms) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall {ann}. Doc ann
softline Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Syntax' () -> Doc a
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax' ()
rest
 where
  (Syntax' ()
rest, [(Text, Maybe Type)]
lms) = Syntax' () -> (Syntax' (), [(Text, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
unchainLambdas (Term -> Syntax' ()
STerm (Term' ty -> Term
forall (t :: * -> *) ty. Functor t => t ty -> t ()
erase Term' ty
t))

unchainLambdas :: Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
unchainLambdas :: forall ty. Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
unchainLambdas = \case
  -- Peel off consecutive lambdas, being sure to accumulate any
  -- attached comments along the way so they attach to the body
  Syntax' SrcLoc
_ (SLam (LV SrcLoc
_ Text
x) Maybe Type
mty Syntax' ty
body) Comments
coms ty
_ -> ((Text
x, Maybe Type
mty) (Text, Maybe Type) -> [(Text, Maybe Type)] -> [(Text, Maybe Type)]
forall a. a -> [a] -> [a]
:) ([(Text, Maybe Type)] -> [(Text, Maybe Type)])
-> (Syntax' ty, [(Text, Maybe Type)])
-> (Syntax' ty, [(Text, Maybe Type)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
forall ty. Syntax' ty -> (Syntax' ty, [(Text, Maybe Type)])
unchainLambdas (Syntax' ty
body Syntax' ty -> (Syntax' ty -> Syntax' ty) -> Syntax' ty
forall a b. a -> (a -> b) -> b
& (Comments -> Identity Comments)
-> Syntax' ty -> Identity (Syntax' ty)
forall ty (f :: * -> *).
Functor f =>
(Comments -> f Comments) -> Syntax' ty -> f (Syntax' ty)
sComments ((Comments -> Identity Comments)
 -> Syntax' ty -> Identity (Syntax' ty))
-> Comments -> Syntax' ty -> Syntax' ty
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Comments
coms)
  Syntax' ty
body -> (Syntax' ty
body, [])

prettyLambda :: (PrettyPrec a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann
prettyLambda :: forall a b ann.
(PrettyPrec a, PrettyPrec b) =>
(a, Maybe b) -> Doc ann
prettyLambda (a1
x, Maybe a2
mty) = Doc ann
"\\" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a1 -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr a1
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> (a2 -> Doc ann) -> Maybe a2 -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
"" ((Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann) -> (a2 -> Doc ann) -> a2 -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a2 -> Doc ann
forall a ann. PrettyPrec a => a -> Doc ann
ppr) Maybe a2
mty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."