{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | The Eidos concrete syntax (.eir) pretty-printer, implementing
--   doc/eidos.md §9. "ReWire.Eidos.Parse" is the other half of the
--   round-trip contract: @parse . pretty@ is the identity on programs
--   modulo annotations (annotations are semantically inert and never
--   printed), and @pretty . parse . pretty == pretty@ is a tested fixpoint.
--
--   Conventions (§9): term names, type variables, and labels print with
--   their uniques (@x#12@, @Main.loop#3@, @a#7@); type and data constructor
--   names print bare (@Main.CPUState@, @Vec@); primitives print by their
--   builtin name (@rwPrimBind@) — the @rwPrim@ prefix and absence of @#@
--   distinguishes them lexically from constructors and variables. Binders
--   print @(occ#uniq :: ty)@ (the case binder, whose type is the
--   scrutinee's, prints bare); 'Con', 'Prim', and integer-literal
--   occurrences print in the parenthesized-ascription form @(name :: ty)@;
--   type arguments print @\@tyatom@. The default case alternative, when
--   present, is first in the AST (the Core convention) and prints first,
--   as @_ -> e@.
--
--   Nothing in this module introduces a soft line break: layout is fixed
--   by 'vsep' alone, so signatures (and every type) always print on one
--   line — the @defn@ production's newline between the signature line and
--   the equation line is what terminates the signature's type.
--
--   The machine level's process declarations print through
--   "ReWire.Synolon.Pretty", which reuses these printers for the
--   expressions, definitions, and datatypes a Synolon program embeds.
module ReWire.Eidos.Pretty
      ( prettyProgram
      , ppProgram, ppDataDefn, ppDefn
      , ppExp, ppBind, ppAlt
      , ppTy, ppSig, ppKind
      , ppId, ppTyVar, ppBinder, ppName
      , ppOcc, ppOcc', ppAtom, ppStrLit
      ) where

import ReWire.Builtins (builtinName)
import ReWire.Eidos.Lexer (reservedWords, isIdentStart, isIdentChar)
import ReWire.Eidos.Syntax
import ReWire.Pretty (Doc, Pretty (pretty), text, int, vsep, hsep, nest, align, parens, brackets, dquotes, punctuate, comma, semi, (<+>), prettyPrint')

import Data.List (intersperse)
import Data.Text (Text)

import qualified Data.HashSet as Set
import qualified Data.Text    as T

-- | Render a whole program in the .eir concrete syntax.
prettyProgram :: Program -> Text
prettyProgram :: Program -> Text
prettyProgram = Doc (ZonkAny 0) -> Text
forall ann. Doc ann -> Text
prettyPrint' (Doc (ZonkAny 0) -> Text)
-> (Program -> Doc (ZonkAny 0)) -> Program -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> Doc (ZonkAny 0)
forall an. Program -> Doc an
ppProgram

---
--- Names.
---

-- | A unique-carrying name occurrence: @occ#uniq@. Occurrence text that
--   does not lex as an identifier (operator names, reserved words) prints
--   backtick-quoted: @`GHC.Classes.&&`#5@.
ppName :: Text -> Uniq -> Doc an
ppName :: forall an. Text -> Uniq -> Doc an
ppName Text
occ Uniq
u = Text -> Doc an
forall an. Text -> Doc an
ppOcc Text
occ Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Text -> Doc an
forall an. Text -> Doc an
text Text
"#" Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Uniq -> Doc an
forall ann. Uniq -> Doc ann
int Uniq
u

-- | Like 'ppOcc', but the tuple, unit, and list constructor names print
--   bare (they have their own lexemes in the grammar).
ppOcc' :: Text -> Doc an
ppOcc' :: forall an. Text -> Doc an
ppOcc' Text
occ
      | Text
occ Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Text
"[]", Text
"[_]"] :: [Text]) = Text -> Doc an
forall an. Text -> Doc an
text Text
occ
      | Text -> Text -> Bool
T.isPrefixOf Text
"(" Text
occ                 = Text -> Doc an
forall an. Text -> Doc an
text Text
occ
      | Bool
otherwise                            = Text -> Doc an
forall an. Text -> Doc an
ppOcc Text
occ

-- | Occurrence text, backtick-quoted unless it lexes as an identifier
--   (the lexer's own predicate and reserved-word table decide).
ppOcc :: Text -> Doc an
ppOcc :: forall an. Text -> Doc an
ppOcc Text
occ
      | Bool
lexable   = Text -> Doc an
forall an. Text -> Doc an
text Text
occ
      | Bool
otherwise = Text -> Doc an
forall an. Text -> Doc an
text Text
"`" Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Text -> Doc an
forall an. Text -> Doc an
text Text
occ Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Text -> Doc an
forall an. Text -> Doc an
text Text
"`"
      where lexable :: Bool
            lexable :: Bool
lexable = case Text -> Maybe (Char, Text)
T.uncons Text
occ of
                  Just (Char
c, Text
_) -> Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isIdentChar Text
occ Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
occ Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet Text
reservedWords)
                  Maybe (Char, Text)
Nothing     -> Bool
False

-- | A term name occurrence: @x#12@ (the type is read off the binder).
ppId :: Id -> Doc an
ppId :: forall an. Id -> Doc an
ppId Id
x = Text -> Uniq -> Doc an
forall an. Text -> Uniq -> Doc an
ppName (Id -> Text
idOcc Id
x) (Id -> Uniq
idUniq Id
x)

-- | A type variable occurrence: @a#7@.
ppTyVar :: TyVar -> Doc an
ppTyVar :: forall an. TyVar -> Doc an
ppTyVar TyVar
a = Text -> Uniq -> Doc an
forall an. Text -> Uniq -> Doc an
ppName (TyVar -> Text
tvOcc TyVar
a) (TyVar -> Uniq
tvUniq TyVar
a)

-- | A term binder: @(occ#uniq :: ty)@. Local binders are monomorphic
--   (doc/eidos.md §3.2), so only the signature's type is printed.
ppBinder :: Id -> Doc an
ppBinder :: forall an. Id -> Doc an
ppBinder Id
x = Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Id -> Doc an
forall an. Id -> Doc an
ppId Id
x Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy (Sig -> Ty
sigTy (Sig -> Ty) -> Sig -> Ty
forall a b. (a -> b) -> a -> b
$ Id -> Sig
idSig Id
x)

-- | A type variable binder (in a @forall@): @(a#7 :: kind)@.
ppTyVarBinder :: TyVar -> Doc an
ppTyVarBinder :: forall an. TyVar -> Doc an
ppTyVarBinder TyVar
a = Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ TyVar -> Doc an
forall an. TyVar -> Doc an
ppTyVar TyVar
a Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Kind -> Doc an
forall an. Kind -> Doc an
ppKind (TyVar -> Kind
tvKind TyVar
a)

---
--- Kinds, types, signatures.
---

-- | Kind, at top (arrow) level: arrows are right-associative.
ppKind :: Kind -> Doc an
ppKind :: forall an. Kind -> Doc an
ppKind = \ case
      KFun Kind
k1 Kind
k2 -> Kind -> Doc an
forall an. Kind -> Doc an
ppKindAtom Kind
k1 Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Kind -> Doc an
forall an. Kind -> Doc an
ppKind Kind
k2
      Kind
k          -> Kind -> Doc an
forall an. Kind -> Doc an
ppKindAtom Kind
k

ppKindAtom :: Kind -> Doc an
ppKindAtom :: forall an. Kind -> Doc an
ppKindAtom = \ case
      Kind
KStar -> Text -> Doc an
forall an. Text -> Doc an
text Text
"*"
      Kind
KNat  -> Text -> Doc an
forall an. Text -> Doc an
text Text
"Nat"
      Kind
k     -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Kind -> Doc an
forall an. Kind -> Doc an
ppKind Kind
k

-- | Type, at top (arrow) level: arrows are right-associative and bind
--   loosest; application binds tighter.
ppTy :: Ty -> Doc an
ppTy :: forall an. Ty -> Doc an
ppTy = \ case
      Arrow Annote
_ Ty
t Ty
u -> Ty -> Doc an
forall an. Ty -> Doc an
ppTyApp Ty
t Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
u
      Ty
t           -> Ty -> Doc an
forall an. Ty -> Doc an
ppTyApp Ty
t

-- | Type, at application level (left-associative).
ppTyApp :: Ty -> Doc an
ppTyApp :: forall an. Ty -> Doc an
ppTyApp = \ case
      TyApp Annote
_ Ty
t Ty
u -> Ty -> Doc an
forall an. Ty -> Doc an
ppTyApp Ty
t Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTyAtom Ty
u
      Ty
t           -> Ty -> Doc an
forall an. Ty -> Doc an
ppTyAtom Ty
t

-- | Type, at atom level: constructors, variables, and naturals print bare;
--   everything else parenthesizes.
ppTyAtom :: Ty -> Doc an
ppTyAtom :: forall an. Ty -> Doc an
ppTyAtom = \ case
      TyCon Annote
_ Text
c  -> Text -> Doc an
forall an. Text -> Doc an
text Text
c
      TyVarT Annote
_ TyVar
a -> TyVar -> Doc an
forall an. TyVar -> Doc an
ppTyVar TyVar
a
      TyNat Annote
_ Natural
n  -> Natural -> Doc an
forall ann. Natural -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Natural
n
      Ty
t          -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t

-- | A signature: @forall (a#1 :: kind) ... . ty@, or bare @ty@ when the
--   quantifier list is empty.
ppSig :: Sig -> Doc an
ppSig :: forall an. Sig -> Doc an
ppSig (Sig [TyVar]
tvs Ty
t) = case [TyVar]
tvs of
      [] -> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      [TyVar]
_  -> Text -> Doc an
forall an. Text -> Doc an
text Text
"forall" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ((TyVar -> Doc an) -> [TyVar] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Doc an
forall an. TyVar -> Doc an
ppTyVarBinder [TyVar]
tvs) Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Text -> Doc an
forall an. Text -> Doc an
text Text
"." Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t

---
--- Expressions.
---

-- | Expression at top level: lambda, let, case, and jump live here; all
--   are parenthesized down at atom level.
ppExp :: Exp -> Doc an
ppExp :: forall an. Exp -> Doc an
ppExp = \ case
      Lam Annote
_ Id
x Exp
e         -> Id -> Exp -> Doc an
forall an. Id -> Exp -> Doc an
ppLam Id
x Exp
e
      Let Annote
_ Bind
b Exp
e         -> [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep [ Text -> Doc an
forall an. Text -> Doc an
text Text
"let" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bind -> Doc an
forall an. Bind -> Doc an
ppBind Bind
b Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"in", Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e ]
      Case Annote
_ Ty
t Exp
e Id
x [Alt]
alts -> Ty -> Exp -> Id -> [Alt] -> Doc an
forall an. Ty -> Exp -> Id -> [Alt] -> Doc an
ppCase Ty
t Exp
e Id
x [Alt]
alts
      Jump Annote
_ JoinId
j [Exp]
es       -> Text -> Doc an
forall an. Text -> Doc an
text Text
"jump" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> Doc an
forall an. Id -> Doc an
ppId (JoinId -> Id
jpId JoinId
j) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens ([Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
comma ([Doc an] -> [Doc an]) -> [Doc an] -> [Doc an]
forall a b. (a -> b) -> a -> b
$ (Exp -> Doc an) -> [Exp] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Doc an
forall an. Exp -> Doc an
ppExp [Exp]
es)
      Exp
e                 -> Exp -> Doc an
forall an. Exp -> Doc an
ppApp Exp
e

-- | A lambda: nested 'Lam's collapse into one parameter telescope,
--   @\\ (x#1 :: ty) (y#2 :: ty) -> e@.
ppLam :: Id -> Exp -> Doc an
ppLam :: forall an. Id -> Exp -> Doc an
ppLam Id
x Exp
e = Text -> Doc an
forall an. Text -> Doc an
text Text
"\\" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ((Id -> Doc an) -> [Id] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Doc an
forall an. Id -> Doc an
ppBinder ([Id] -> [Doc an]) -> [Id] -> [Doc an]
forall a b. (a -> b) -> a -> b
$ Id
x Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
xs) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
body)
      where ([Id]
xs, Exp
body) = Exp -> ([Id], Exp)
flattenLam Exp
e

            flattenLam :: Exp -> ([Id], Exp)
            flattenLam :: Exp -> ([Id], Exp)
flattenLam = \ case
                  Lam Annote
_ Id
y Exp
b -> let ([Id]
ys, Exp
b') = Exp -> ([Id], Exp)
flattenLam Exp
b in (Id
y Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
ys, Exp
b')
                  Exp
b         -> ([], Exp
b)

-- | @case e of x#u { alt; ... } :: ty@ — the case binder prints bare (its
--   type is the scrutinee's); the carried result type follows the braces.
ppCase :: Ty -> Exp -> Id -> [Alt] -> Doc an
ppCase :: forall an. Ty -> Exp -> Id -> [Alt] -> Doc an
ppCase Ty
t Exp
e Id
x [Alt]
alts = [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep
      [ Uniq -> Doc an -> Doc an
forall ann. Uniq -> Doc ann -> Doc ann
nest Uniq
6 (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ (Text -> Doc an
forall an. Text -> Doc an
text Text
"case" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"of" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> Doc an
forall an. Id -> Doc an
ppId Id
x Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"{")
                      Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
: Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
semi ((Alt -> Doc an) -> [Alt] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Alt -> Doc an
forall an. Alt -> Doc an
ppAlt [Alt]
alts)
      , Text -> Doc an
forall an. Text -> Doc an
text Text
"}" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      ]

-- | A case alternative. Default and literal alternatives bind no fields
--   (the grammar has no slot for them; the linter enforces emptiness).
ppAlt :: Alt -> Doc an
ppAlt :: forall an. Alt -> Doc an
ppAlt (Alt Annote
_ AltCon
c [Id]
xs Exp
e) = case AltCon
c of
      AltCon
DefaultAlt -> Text -> Doc an
forall an. Text -> Doc an
text Text
"_" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e)
      DataAlt Text
d  -> [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep (Text -> Doc an
forall an. Text -> Doc an
ppOcc' Text
d Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
: (Id -> Doc an) -> [Id] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Doc an
forall an. Id -> Doc an
ppBinder [Id]
xs) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e)
      LitAlt Integer
n   -> Integer -> Doc an
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"->" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e)

-- | A local binding (the part between @let@ and @in@).
ppBind :: Bind -> Doc an
ppBind :: forall an. Bind -> Doc an
ppBind = \ case
      NonRec Id
x Exp
e  -> Id -> Exp -> Doc an
forall an. Id -> Exp -> Doc an
ppEq Id
x Exp
e
      Rec [(Id, Exp)]
eqs     -> [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep [ Uniq -> Doc an -> Doc an
forall ann. Uniq -> Doc ann -> Doc ann
nest Uniq
6 (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
text Text
"rec {" Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
: Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
semi (((Id, Exp) -> Doc an) -> [(Id, Exp)] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Exp -> Doc an) -> (Id, Exp) -> Doc an
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> Exp -> Doc an
forall an. Id -> Exp -> Doc an
ppEq) [(Id, Exp)]
eqs), Text -> Doc an
forall an. Text -> Doc an
text Text
"}" ]
      Join JoinId
j [Id]
xs Exp
e -> Text -> Doc an
forall an. Text -> Doc an
text Text
"join" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> Doc an
forall an. Id -> Doc an
ppId (JoinId -> Id
jpId JoinId
j)
                 Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens ([Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
comma ([Doc an] -> [Doc an]) -> [Doc an] -> [Doc an]
forall a b. (a -> b) -> a -> b
$ (Id -> Doc an) -> [Id] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Doc an
forall an. Id -> Doc an
ppBinder [Id]
xs)
                 Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"=" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e)

-- | One equation of a (non-recursive or recursive) let: @x#u :: ty = e@.
ppEq :: Id -> Exp -> Doc an
ppEq :: forall an. Id -> Exp -> Doc an
ppEq Id
x Exp
e = Id -> Doc an
forall an. Id -> Doc an
ppId Id
x Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy (Sig -> Ty
sigTy (Sig -> Ty) -> Sig -> Ty
forall a b. (a -> b) -> a -> b
$ Id -> Sig
idSig Id
x) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"=" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e)

-- | Expression at application level (left-associative); the head, if not
--   itself an application, prints at atom level.
ppApp :: Exp -> Doc an
ppApp :: forall an. Exp -> Doc an
ppApp = \ case
      App Annote
_ Exp
e Arg
a -> Exp -> Doc an
forall an. Exp -> Doc an
ppApp Exp
e Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Arg -> Doc an
forall an. Arg -> Doc an
ppArg Arg
a
      Exp
e         -> Exp -> Doc an
forall an. Exp -> Doc an
ppAtom Exp
e

-- | An application argument: an atom, or @\@tyatom@ for a type argument.
ppArg :: Arg -> Doc an
ppArg :: forall an. Arg -> Doc an
ppArg = \ case
      EArg Exp
e -> Exp -> Doc an
forall an. Exp -> Doc an
ppAtom Exp
e
      TArg Ty
t -> Text -> Doc an
forall an. Text -> Doc an
text Text
"@" Doc an -> Doc an -> Doc an
forall a. Semigroup a => a -> a -> a
<> Ty -> Doc an
forall an. Ty -> Doc an
ppTyAtom Ty
t

-- | Expression at atom level. 'Con', 'Prim', integer, list, and vector
--   literals are self-parenthesizing ascription forms; variables and
--   string literals print bare; everything else parenthesizes.
ppAtom :: Exp -> Doc an
ppAtom :: forall an. Exp -> Doc an
ppAtom = \ case
      Var Annote
_ Id
x        -> Id -> Doc an
forall an. Id -> Doc an
ppId Id
x
      Con Annote
_ Ty
t Text
c      -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
ppOcc' Text
c Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      Prim Annote
_ Ty
t Builtin
p     -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
text (Builtin -> Text
builtinName Builtin
p) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      LitInt Annote
_ Ty
t Integer
n   -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Integer -> Doc an
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      LitStr Annote
_ Text
s     -> Text -> Doc an
forall an. Text -> Doc an
ppStrLit Text
s
      LitList Annote
_ Ty
t [Exp]
es -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
text Text
"list" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Exp] -> Doc an
forall an. [Exp] -> Doc an
ppExpList [Exp]
es Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      LitVec Annote
_ Ty
t [Exp]
es  -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
text Text
"vec" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Exp] -> Doc an
forall an. [Exp] -> Doc an
ppExpList [Exp]
es Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ty -> Doc an
forall an. Ty -> Doc an
ppTy Ty
t
      Exp
e              -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e

ppExpList :: [Exp] -> Doc an
ppExpList :: forall an. [Exp] -> Doc an
ppExpList [Exp]
es = Doc an -> Doc an
forall ann. Doc ann -> Doc ann
brackets (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
comma ([Doc an] -> [Doc an]) -> [Doc an] -> [Doc an]
forall a b. (a -> b) -> a -> b
$ (Exp -> Doc an) -> [Exp] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Doc an
forall an. Exp -> Doc an
ppExp [Exp]
es

ppStrLit :: Text -> Doc an
ppStrLit :: forall an. Text -> Doc an
ppStrLit Text
s = Doc an -> Doc an
forall ann. Doc ann -> Doc ann
dquotes (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Text -> Doc an
forall an. Text -> Doc an
text (Text -> Doc an) -> Text -> Doc an
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
esc Text
s
      where esc :: Char -> Text
            esc :: Char -> Text
esc = \ case
                  Char
'"'  -> Text
"\\\""
                  Char
'\\' -> Text
"\\\\"
                  Char
'\n' -> Text
"\\n"
                  Char
'\t' -> Text
"\\t"
                  Char
'\r' -> Text
"\\r"
                  Char
c    -> Char -> Text
T.singleton Char
c

---
--- Definitions, datatypes, programs.
---

-- | A definition: the signature line, then the equation line (attributes,
--   name, parameter telescope) with the body on a continuation line.
ppDefn :: Defn -> Doc an
ppDefn :: forall an. Defn -> Doc an
ppDefn (Defn Annote
_ Id
x [Id]
ps Exp
e Maybe DefnAttr
attr Maybe SpecOrigin
orig) = [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep
      [ Id -> Doc an
forall an. Id -> Doc an
ppId Id
x Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Sig -> Doc an
forall an. Sig -> Doc an
ppSig (Id -> Sig
idSig Id
x)
      , Uniq -> Doc an -> Doc an
forall ann. Uniq -> Doc ann -> Doc ann
nest Uniq
6 (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep [ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep (Maybe DefnAttr -> Maybe SpecOrigin -> [Doc an]
forall an. Maybe DefnAttr -> Maybe SpecOrigin -> [Doc an]
ppAttrs Maybe DefnAttr
attr Maybe SpecOrigin
orig [Doc an] -> [Doc an] -> [Doc an]
forall a. Semigroup a => a -> a -> a
<> (Id -> Doc an
forall an. Id -> Doc an
ppId Id
x Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
: (Id -> Doc an) -> [Id] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Doc an
forall an. Id -> Doc an
ppBinder [Id]
ps)) Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"=", Doc an -> Doc an
forall ann. Doc ann -> Doc ann
align (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ Exp -> Doc an
forall an. Exp -> Doc an
ppExp Exp
e ]
      ]

ppAttrs :: Maybe DefnAttr -> Maybe SpecOrigin -> [Doc an]
ppAttrs :: forall an. Maybe DefnAttr -> Maybe SpecOrigin -> [Doc an]
ppAttrs Maybe DefnAttr
attr Maybe SpecOrigin
orig = [Doc an] -> (DefnAttr -> [Doc an]) -> Maybe DefnAttr -> [Doc an]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Doc an -> [Doc an]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc an -> [Doc an])
-> (DefnAttr -> Doc an) -> DefnAttr -> [Doc an]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefnAttr -> Doc an
forall an. DefnAttr -> Doc an
ppAttr) Maybe DefnAttr
attr [Doc an] -> [Doc an] -> [Doc an]
forall a. Semigroup a => a -> a -> a
<> [Doc an]
-> (SpecOrigin -> [Doc an]) -> Maybe SpecOrigin -> [Doc an]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Doc an -> [Doc an]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc an -> [Doc an])
-> (SpecOrigin -> Doc an) -> SpecOrigin -> [Doc an]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecOrigin -> Doc an
forall an. SpecOrigin -> Doc an
ppOrigin) Maybe SpecOrigin
orig
      where ppAttr :: DefnAttr -> Doc an
            ppAttr :: forall an. DefnAttr -> Doc an
ppAttr = \ case
                  DefnAttr
Inline   -> Text -> Doc an
forall an. Text -> Doc an
text Text
"inline"
                  DefnAttr
NoInline -> Text -> Doc an
forall an. Text -> Doc an
text Text
"noinline"

            ppOrigin :: SpecOrigin -> Doc an
            ppOrigin :: forall an. SpecOrigin -> Doc an
ppOrigin = \ case
                  SpecOrigin Text
f [Ty]
ts -> Text -> Doc an
forall an. Text -> Doc an
text Text
"from" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
ppOcc Text
f Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc an -> Doc an
forall ann. Doc ann -> Doc ann
parens ([Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
hsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
comma ([Doc an] -> [Doc an]) -> [Doc an] -> [Doc an]
forall a b. (a -> b) -> a -> b
$ (Ty -> Doc an) -> [Ty] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Ty -> Doc an
forall an. Ty -> Doc an
ppTy [Ty]
ts)
                  BakeOrigin Text
f    -> Text -> Doc an
forall an. Text -> Doc an
text Text
"baked" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
ppOcc Text
f

-- | @data T kind { C1 :: sig1; ... }@.
ppDataDefn :: DataDefn -> Doc an
ppDataDefn :: forall an. DataDefn -> Doc an
ppDataDefn (DataDefn Annote
_ Text
n Kind
k [DataCon]
cs) = [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep
      [ Uniq -> Doc an -> Doc an
forall ann. Uniq -> Doc ann -> Doc ann
nest Uniq
6 (Doc an -> Doc an) -> Doc an -> Doc an
forall a b. (a -> b) -> a -> b
$ [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ (Text -> Doc an
forall an. Text -> Doc an
text Text
"data" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
ppOcc' Text
n Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Kind -> Doc an
forall an. Kind -> Doc an
ppKind Kind
k Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"{")
                      Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
: Doc an -> [Doc an] -> [Doc an]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc an
forall ann. Doc ann
semi ((DataCon -> Doc an) -> [DataCon] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Doc an
forall an. DataCon -> Doc an
ppDataCon [DataCon]
cs)
      , Text -> Doc an
forall an. Text -> Doc an
text Text
"}"
      ]

ppDataCon :: DataCon -> Doc an
ppDataCon :: forall an. DataCon -> Doc an
ppDataCon (DataCon Annote
_ Text
c Sig
sig) = Text -> Doc an
forall an. Text -> Doc an
ppOcc' Text
c Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc an
forall an. Text -> Doc an
text Text
"::" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Sig -> Doc an
forall an. Sig -> Doc an
ppSig Sig
sig

-- | A whole program: datatypes, definitions, and the @top@ designation,
--   separated by blank lines.
ppProgram :: Program -> Doc an
ppProgram :: forall an. Program -> Doc an
ppProgram (Program [DataDefn]
datas [Defn]
defns Id
top) = [Doc an] -> Doc an
forall ann. [Doc ann] -> Doc ann
vsep ([Doc an] -> Doc an) -> [Doc an] -> Doc an
forall a b. (a -> b) -> a -> b
$ Doc an -> [Doc an] -> [Doc an]
forall a. a -> [a] -> [a]
intersperse (Text -> Doc an
forall an. Text -> Doc an
text Text
"") ([Doc an] -> [Doc an]) -> [Doc an] -> [Doc an]
forall a b. (a -> b) -> a -> b
$
      (DataDefn -> Doc an) -> [DataDefn] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map DataDefn -> Doc an
forall an. DataDefn -> Doc an
ppDataDefn [DataDefn]
datas
      [Doc an] -> [Doc an] -> [Doc an]
forall a. Semigroup a => a -> a -> a
<> (Defn -> Doc an) -> [Defn] -> [Doc an]
forall a b. (a -> b) -> [a] -> [b]
map Defn -> Doc an
forall an. Defn -> Doc an
ppDefn [Defn]
defns
      [Doc an] -> [Doc an] -> [Doc an]
forall a. Semigroup a => a -> a -> a
<> [ Text -> Doc an
forall an. Text -> Doc an
text Text
"top" Doc an -> Doc an -> Doc an
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Id -> Doc an
forall an. Id -> Doc an
ppId Id
top ]

---
--- Pretty instances (canonical companion instances for the Eidos AST;
--- ReWire.Eidos.Syntax deliberately contains no printing code).
---

instance Pretty Kind where
      pretty :: forall an. Kind -> Doc an
pretty = Kind -> Doc ann
forall an. Kind -> Doc an
ppKind

instance Pretty TyVar where
      pretty :: forall an. TyVar -> Doc an
pretty = TyVar -> Doc ann
forall an. TyVar -> Doc an
ppTyVar

instance Pretty Ty where
      pretty :: forall an. Ty -> Doc an
pretty = Ty -> Doc ann
forall an. Ty -> Doc an
ppTy

instance Pretty Sig where
      pretty :: forall an. Sig -> Doc an
pretty = Sig -> Doc ann
forall an. Sig -> Doc an
ppSig

instance Pretty Id where
      pretty :: forall an. Id -> Doc an
pretty = Id -> Doc ann
forall an. Id -> Doc an
ppId

instance Pretty Exp where
      pretty :: forall an. Exp -> Doc an
pretty = Exp -> Doc ann
forall an. Exp -> Doc an
ppExp

instance Pretty Arg where
      pretty :: forall an. Arg -> Doc an
pretty = Arg -> Doc ann
forall an. Arg -> Doc an
ppArg

instance Pretty Bind where
      pretty :: forall an. Bind -> Doc an
pretty = Bind -> Doc ann
forall an. Bind -> Doc an
ppBind

instance Pretty Alt where
      pretty :: forall an. Alt -> Doc an
pretty = Alt -> Doc ann
forall an. Alt -> Doc an
ppAlt

instance Pretty Defn where
      pretty :: forall an. Defn -> Doc an
pretty = Defn -> Doc ann
forall an. Defn -> Doc an
ppDefn

instance Pretty DataCon where
      pretty :: forall an. DataCon -> Doc an
pretty = DataCon -> Doc ann
forall an. DataCon -> Doc an
ppDataCon

instance Pretty DataDefn where
      pretty :: forall an. DataDefn -> Doc an
pretty = DataDefn -> Doc ann
forall an. DataDefn -> Doc an
ppDataDefn

instance Pretty Program where
      pretty :: forall an. Program -> Doc an
pretty = Program -> Doc ann
forall an. Program -> Doc an
ppProgram