module Unison.Syntax.TermPrinter
  ( emptyAc,
    pretty,
    prettyBlock,
    prettyBlock',
    pretty',
    prettyBinding,
    prettyBinding',
    prettyBindingWithoutTypeSignature,
    prettyDoc2,
    pretty0,
    runPretty,
    prettyPattern,
  )
where

import Control.Lens (unsnoc)
import Control.Monad.Reader (ask, local)
import Control.Monad.State (evalState)
import Control.Monad.State qualified as State
import Data.Char (isPrint)
import Data.Foldable qualified as Foldable
import Data.List
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text (unpack)
import Data.Text qualified as Text
import Data.Vector ()
import Text.Show.Unicode qualified as U
import Unison.ABT (annotation, reannotateUp, pattern AbsN')
import Unison.ABT qualified as ABT
import Unison.Blank qualified as Blank
import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm')
import Unison.Builtin.Decls qualified as DD
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorReference qualified as ConstructorReference
import Unison.ConstructorType qualified as CT
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Pattern (Pattern)
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
import Unison.PrettyPrintEnv qualified as PrettyPrintEnv
import Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN)
import Unison.PrettyPrintEnv.MonadPretty
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar)
import Unison.Syntax.Lexer.Unison (showEscapeChar)
import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText, unsafeParseVar)
import Unison.Syntax.NamePrinter (styleHashQualified'')
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.Syntax.Precedence (InfixPrecedence (..), Precedence (..), increment, isTopLevelPrecedence, operatorPrecedence)
import Unison.Syntax.TypePrinter qualified as TypePrinter
import Unison.Term
import Unison.Type (Type, pattern ForallsNamed')
import Unison.Type qualified as Type
import Unison.Util.Bytes qualified as Bytes
import Unison.Util.Monoid (foldMapM, intercalateMap, intercalateMapM)
import Unison.Util.Pretty (ColorText, Pretty, Width)
import Unison.Util.Pretty qualified as PP
import Unison.Util.SyntaxText qualified as S
import Unison.Var (Var)
import Unison.Var qualified as Var

type SyntaxText = S.SyntaxText' Reference

pretty :: (Var v) => PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty :: forall v a. Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText
pretty PrettyPrintEnv
ppe Term v a
tm =
  Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor (Pretty SyntaxText -> Pretty ColorText)
-> (Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText)
-> Reader (Env v) (Pretty SyntaxText)
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText
forall v a. Var v => PrettyPrintEnv -> Reader (Env v) a -> a
runPretty (Term v a -> PrettyPrintEnv -> PrettyPrintEnv
forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term v a
tm PrettyPrintEnv
ppe) (Reader (Env v) (Pretty SyntaxText) -> Pretty ColorText)
-> Reader (Env v) (Pretty SyntaxText) -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ AmbientContext
-> Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
emptyAc (Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText))
-> Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Term3 v PrintAnnotation
forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate PrettyPrintEnv
ppe Term v a
tm

prettyBlock :: (Var v) => Bool -> PrettyPrintEnv -> Term v a -> Pretty ColorText
prettyBlock :: forall v a.
Var v =>
Bool -> PrettyPrintEnv -> Term v a -> Pretty ColorText
prettyBlock Bool
elideUnit PrettyPrintEnv
ppe = Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor (Pretty SyntaxText -> Pretty ColorText)
-> (Term v a -> Pretty SyntaxText) -> Term v a -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrettyPrintEnv -> Term v a -> Pretty SyntaxText
forall v a.
Var v =>
Bool -> PrettyPrintEnv -> Term v a -> Pretty SyntaxText
prettyBlock' Bool
elideUnit PrettyPrintEnv
ppe

prettyBlock' :: (Var v) => Bool -> PrettyPrintEnv -> Term v a -> Pretty SyntaxText
prettyBlock' :: forall v a.
Var v =>
Bool -> PrettyPrintEnv -> Term v a -> Pretty SyntaxText
prettyBlock' Bool
elideUnit PrettyPrintEnv
ppe Term v a
tm =
  PrettyPrintEnv
-> Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText
forall v a. Var v => PrettyPrintEnv -> Reader (Env v) a -> a
runPretty (Term v a -> PrettyPrintEnv -> PrettyPrintEnv
forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term v a
tm PrettyPrintEnv
ppe) (Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText)
-> (Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText))
-> Term3 v PrintAnnotation
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbientContext
-> Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (AmbientContext
emptyBlockAc {elideUnit = elideUnit}) (Term3 v PrintAnnotation -> Pretty SyntaxText)
-> Term3 v PrintAnnotation -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Term v a -> Term3 v PrintAnnotation
forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate PrettyPrintEnv
ppe Term v a
tm

pretty' :: (Var v) => Maybe Width -> PrettyPrintEnv -> Term v a -> ColorText
pretty' :: forall v a.
Var v =>
Maybe Width -> PrettyPrintEnv -> Term v a -> ColorText
pretty' (Just Width
width) PrettyPrintEnv
n Term v a
t =
  Width -> Pretty ColorText -> ColorText
forall s. (Monoid s, IsString s) => Width -> Pretty s -> s
PP.render Width
width (Pretty ColorText -> ColorText)
-> (Reader (Env v) (Pretty SyntaxText) -> Pretty ColorText)
-> Reader (Env v) (Pretty SyntaxText)
-> ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor (Pretty SyntaxText -> Pretty ColorText)
-> (Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText)
-> Reader (Env v) (Pretty SyntaxText)
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText
forall v a. Var v => PrettyPrintEnv -> Reader (Env v) a -> a
runPretty (Term v a -> PrettyPrintEnv -> PrettyPrintEnv
forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term v a
t PrettyPrintEnv
n) (Reader (Env v) (Pretty SyntaxText) -> ColorText)
-> Reader (Env v) (Pretty SyntaxText) -> ColorText
forall a b. (a -> b) -> a -> b
$ AmbientContext
-> Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
emptyAc (PrettyPrintEnv -> Term v a -> Term3 v PrintAnnotation
forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate PrettyPrintEnv
n Term v a
t)
pretty' Maybe Width
Nothing PrettyPrintEnv
n Term v a
t =
  Pretty ColorText -> ColorText
forall s. (Monoid s, IsString s) => Pretty s -> s
PP.renderUnbroken (Pretty ColorText -> ColorText)
-> (Reader (Env v) (Pretty SyntaxText) -> Pretty ColorText)
-> Reader (Env v) (Pretty SyntaxText)
-> ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor (Pretty SyntaxText -> Pretty ColorText)
-> (Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText)
-> Reader (Env v) (Pretty SyntaxText)
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyPrintEnv
-> Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText
forall v a. Var v => PrettyPrintEnv -> Reader (Env v) a -> a
runPretty (Term v a -> PrettyPrintEnv -> PrettyPrintEnv
forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term v a
t PrettyPrintEnv
n) (Reader (Env v) (Pretty SyntaxText) -> ColorText)
-> Reader (Env v) (Pretty SyntaxText) -> ColorText
forall a b. (a -> b) -> a -> b
$ AmbientContext
-> Term3 v PrintAnnotation -> Reader (Env v) (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
emptyAc (PrettyPrintEnv -> Term v a -> Term3 v PrintAnnotation
forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate PrettyPrintEnv
n Term v a
t)

-- Information about the context in which a term appears, which affects how the
-- term should be rendered.
data AmbientContext = AmbientContext
  { -- The operator precedence of the enclosing context (a number from 0 to 11,
    -- or -1 to render without outer parentheses unconditionally).
    -- Function application has precedence 10.
    AmbientContext -> Precedence
precedence :: !Precedence,
    AmbientContext -> BlockContext
blockContext :: !BlockContext,
    AmbientContext -> InfixContext
infixContext :: !InfixContext,
    AmbientContext -> Imports
imports :: !Imports,
    AmbientContext -> DocLiteralContext
docContext :: !DocLiteralContext,
    -- `True` if a `()` at the end of a block should be elided
    AmbientContext -> Bool
elideUnit :: !Bool
  }

-- Description of the position of this ABT node, when viewed in the
-- surface syntax.
data BlockContext
  = -- This ABT node is at the top level of a TermParser.block.
    Block
  | Normal
  deriving (BlockContext -> BlockContext -> Bool
(BlockContext -> BlockContext -> Bool)
-> (BlockContext -> BlockContext -> Bool) -> Eq BlockContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockContext -> BlockContext -> Bool
== :: BlockContext -> BlockContext -> Bool
$c/= :: BlockContext -> BlockContext -> Bool
/= :: BlockContext -> BlockContext -> Bool
Eq, Int -> BlockContext -> ShowS
[BlockContext] -> ShowS
BlockContext -> String
(Int -> BlockContext -> ShowS)
-> (BlockContext -> String)
-> ([BlockContext] -> ShowS)
-> Show BlockContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockContext -> ShowS
showsPrec :: Int -> BlockContext -> ShowS
$cshow :: BlockContext -> String
show :: BlockContext -> String
$cshowList :: [BlockContext] -> ShowS
showList :: [BlockContext] -> ShowS
Show)

data InfixContext
  = -- This ABT node is an infix operator being used in infix position.
    Infix
  | NonInfix
  deriving (InfixContext -> InfixContext -> Bool
(InfixContext -> InfixContext -> Bool)
-> (InfixContext -> InfixContext -> Bool) -> Eq InfixContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InfixContext -> InfixContext -> Bool
== :: InfixContext -> InfixContext -> Bool
$c/= :: InfixContext -> InfixContext -> Bool
/= :: InfixContext -> InfixContext -> Bool
Eq, Int -> InfixContext -> ShowS
[InfixContext] -> ShowS
InfixContext -> String
(Int -> InfixContext -> ShowS)
-> (InfixContext -> String)
-> ([InfixContext] -> ShowS)
-> Show InfixContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InfixContext -> ShowS
showsPrec :: Int -> InfixContext -> ShowS
$cshow :: InfixContext -> String
show :: InfixContext -> String
$cshowList :: [InfixContext] -> ShowS
showList :: [InfixContext] -> ShowS
Show)

data DocLiteralContext
  = -- We won't try and render this ABT node or anything under it as a [: @Doc literal :]
    NoDoc
  | -- We'll keep checking as we recurse down
    MaybeDoc
  deriving (DocLiteralContext -> DocLiteralContext -> Bool
(DocLiteralContext -> DocLiteralContext -> Bool)
-> (DocLiteralContext -> DocLiteralContext -> Bool)
-> Eq DocLiteralContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DocLiteralContext -> DocLiteralContext -> Bool
== :: DocLiteralContext -> DocLiteralContext -> Bool
$c/= :: DocLiteralContext -> DocLiteralContext -> Bool
/= :: DocLiteralContext -> DocLiteralContext -> Bool
Eq, Int -> DocLiteralContext -> ShowS
[DocLiteralContext] -> ShowS
DocLiteralContext -> String
(Int -> DocLiteralContext -> ShowS)
-> (DocLiteralContext -> String)
-> ([DocLiteralContext] -> ShowS)
-> Show DocLiteralContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DocLiteralContext -> ShowS
showsPrec :: Int -> DocLiteralContext -> ShowS
$cshow :: DocLiteralContext -> String
show :: DocLiteralContext -> String
$cshowList :: [DocLiteralContext] -> ShowS
showList :: [DocLiteralContext] -> ShowS
Show)

{- Explanation of precedence handling

   We illustrate precedence rules as follows.

     >=Application
       (Application)f (Application)x

   This example shows that a function application f x is enclosed in
   parentheses whenever the ambient precedence around it is >= Application, and that
   when printing its two components, an ambient precedence of Application is used in
   both places.

   The pretty-printer uses the following rules for printing terms.

     >=Top
       let x = (Bottom)y
           (Statement)z

     >=Prefix
       ! (Prefix)x
       ' (Prefix)x
       (Prefix)x ?

     >=(Application)
       (Application)f (Application)x (Application)y ...
       termLink t
       typeLink t

     >=(Infix +)
       (Infix +)x + (Infix +)y + ... (Infix +)z

     Printing an infix operator in infix position has the following additional
     rule: If the operator has a lower precedence than the ambient precedence,
     it is enclosed in parentheses. If the operator has no precedence rule,
     its precedence is assumed to be higher than any operator to its right, and
     lower than any operator to its left.

     >(Control)
       x -> (Control)y

     >=(Control)
       if (Annotation)a then (Annotation)b else (Annotation)c
       handle (Annoration)b with (Annotation)h
       case (Control)x of
         a | (Control)g -> (Control)b

     >=(Annotation)
       (Application)a : (Annotation)Int

   And the following for patterns.

     >=Prefix
       x@(Prefix)p

     >=Application
       Con (Application)p (Application)q ...

     -- never any external parens added around the following
       { p }
       { Eff 10p 10q ... -> 0k }

-}

isBindingSoftHangable :: (Var v) => Term2 v at ap v a -> Bool
isBindingSoftHangable :: forall v at ap a. Var v => Term2 v at ap v a -> Bool
isBindingSoftHangable (Term2 v at ap v a -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable -> Bool
True) = Bool
True
isBindingSoftHangable (Apps' Term2 v at ap v a
_ ([Term2 v at ap v a]
-> Maybe ([Term2 v at ap v a], Term2 v at ap v a)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc -> Just ([Term2 v at ap v a]
_, Term2 v at ap v a
last))) = Term2 v at ap v a -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term2 v at ap v a
last
isBindingSoftHangable Term2 v at ap v a
_ = Bool
False

pretty0 ::
  forall v m.
  (MonadPretty v m) =>
  AmbientContext ->
  Term3 v PrintAnnotation ->
  m (Pretty SyntaxText)
pretty0 :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
a Term3 v PrintAnnotation
tm | Precedence -> Bool
isTopLevelPrecedence (AmbientContext -> Precedence
precedence AmbientContext
a) Bool -> Bool -> Bool
&& Bool -> Bool
not (Term3 v PrintAnnotation -> Bool
forall v at ap a. Var v => Term2 v at ap v a -> Bool
isBindingSoftHangable Term3 v PrintAnnotation
tm) = do
  -- we allow use clause insertion here even when it otherwise wouldn't be
  -- (as long as the tm isn't soft hangable, if it gets soft hung then
  -- adding use clauses beforehand will mess things up)
  Pretty SyntaxText
tmp <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (AmbientContext
a {imports = im, precedence = Bottom}) Term3 v PrintAnnotation
tm
  pure $ [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText]
uses [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText
tmp])
  where
    (Imports
im, [Pretty SyntaxText]
uses) = Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
forall v.
(Var v, Ord v) =>
Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
calcImports (AmbientContext -> Imports
imports AmbientContext
a) Term3 v PrintAnnotation
tm
pretty0
  a :: AmbientContext
a@AmbientContext
    { $sel:precedence:AmbientContext :: AmbientContext -> Precedence
precedence = Precedence
p,
      $sel:blockContext:AmbientContext :: AmbientContext -> BlockContext
blockContext = BlockContext
bc,
      $sel:infixContext:AmbientContext :: AmbientContext -> InfixContext
infixContext = InfixContext
ic,
      $sel:imports:AmbientContext :: AmbientContext -> Imports
imports = Imports
im,
      $sel:docContext:AmbientContext :: AmbientContext -> DocLiteralContext
docContext = DocLiteralContext
doc
    }
  Term3 v PrintAnnotation
term =
    Term3 v PrintAnnotation
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> m (Pretty SyntaxText)
specialCases Term3 v PrintAnnotation
term \case
      Var' v
v -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name =
              if v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Env v
env.freeTerms Bool -> Bool -> Bool
&& v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Env v
env.boundTerms
                then Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.fromName (Name -> Name
Name.makeAbsolute (v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar v
v))
                else Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar (v -> v
forall v. Var v => v -> v
Var.reset v
v)
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var) HashQualified Name
name
      Ref' Reference
r -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe (Reference -> Referent
Referent.Ref Reference
r)
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference (Reference -> Referent
Referent.Ref Reference
r)) HashQualified Name
name
      TermLink' Referent
r -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe Referent
r
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
          Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.LinkKeyword Pretty SyntaxText
"termLink "
            Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic ((Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
r) HashQualified Name
name)
      TypeLink' Reference
r -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Reference -> HashQualified Name
PrettyPrintEnv.typeName Env v
env.ppe Reference
r
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
          Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.LinkKeyword Pretty SyntaxText
"typeLink "
            Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic ((Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Reference -> Element Reference
forall r. r -> Element r
S.TypeReference Reference
r) HashQualified Name
name)
      Ann' Term3 v PrintAnnotation
tm Type v ()
t -> do
        Pretty SyntaxText
tm' <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Application BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
tm
        Pretty SyntaxText
tp' <- Imports -> Int -> Type v () -> m (Pretty SyntaxText)
forall v a (m :: * -> *).
MonadPretty v m =>
Imports -> Int -> Type v a -> m (Pretty SyntaxText)
TypePrinter.pretty0 Imports
im Int
0 Type v ()
t
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Annotation) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
tm' Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TypeAscriptionColon Pretty SyntaxText
" :") Pretty SyntaxText
tp'
      Int' Int64
i -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (String -> Pretty SyntaxText) -> String -> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> m (Pretty SyntaxText))
-> String -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ (if Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 then (String
"+" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
i) else (Int64 -> String
forall a. Show a => a -> String
show Int64
i))
      Nat' Word64
u -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (String -> Pretty SyntaxText) -> String -> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> m (Pretty SyntaxText))
-> String -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show Word64
u
      Float' Double
f -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (String -> Pretty SyntaxText) -> String -> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> m (Pretty SyntaxText))
-> String -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
f
      -- TODO How to handle Infinity, -Infinity and NaN?  Parser cannot parse
      --      them.  Haskell doesn't have literals for them either.  Is this
      --      function only required to operate on terms produced by the parser?
      --      In which case the code is fine as it stands.  If it can somehow run
      --      on values produced by execution (or, one day, on terms produced by
      --      metaprograms), then it needs to be able to print them (and then the
      --      parser ought to be able to parse them, to maintain symmetry.)
      Boolean' Bool
b -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BooleanLiteral (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ if Bool
b then String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"true" else String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"false"
      Text' Text
s
        | Just Text
quotes <- Text -> Maybe Text
useRaw Text
s ->
            Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TextLiteral (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
quotes Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
s Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
quotes
        where
          -- we only use this syntax if we're not wrapped in something else,
          -- to avoid possible round trip issues if the text ends at an odd column
          useRaw :: Text -> Maybe Text
useRaw Text
_ | Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Annotation = Maybe Text
forall a. Maybe a
Nothing
          useRaw Text
s | (Char -> Bool) -> Text -> Maybe Char
Text.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\n' Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
ok Text
s = Int -> Maybe Text
n Int
3
          useRaw Text
_ = Maybe Text
forall a. Maybe a
Nothing
          ok :: Char -> Bool
ok Char
ch = Char -> Bool
isPrint Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
          -- Picks smallest number of surrounding """ to be unique
          n :: Int -> Maybe Text
n Int
10 = Maybe Text
forall a. Maybe a
Nothing -- bail at 10, avoiding quadratic behavior in weird cases
          n Int
cur =
            if [(Text, Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasCallStack => Text -> Text -> [(Text, Text)]
Text -> Text -> [(Text, Text)]
Text.breakOnAll Text
quotes Text
s)
              then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
quotes
              else Int -> Maybe Text
n (Int
cur Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            where
              quotes :: Text
quotes = String -> Text
Text.pack (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
cur Char
'"')
      Text' Text
s -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TextLiteral (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
U.ushow Text
s
      Char' Char
c -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (String -> Pretty SyntaxText) -> String -> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.CharLiteral
        (Pretty SyntaxText -> Pretty SyntaxText)
-> (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l
        (String -> m (Pretty SyntaxText))
-> String -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ case Char -> Maybe Char
showEscapeChar Char
c of
          Just Char
c -> String
"?\\" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
          Maybe Char
Nothing -> Char
'?' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char
c]
      Blank' Blank ()
id -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Blank (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"_" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Blank () -> Maybe String
forall loc. Blank loc -> Maybe String
Blank.nameb Blank ()
id))
      Constructor' ConstructorReference
ref -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe Referent
conRef
            conRef :: Referent
conRef = ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
CT.Data
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef) HashQualified Name
name
      Request' ConstructorReference
ref -> do
        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe Referent
conRef
            conRef :: Referent
conRef = ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
CT.Effect
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef) HashQualified Name
name
      Handle' Term3 v PrintAnnotation
h Term3 v PrintAnnotation
body -> do
        Pretty SyntaxText
pb <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
body
        Pretty SyntaxText
ph <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
h
        let hangHandler :: Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
hangHandler = case Term3 v PrintAnnotation
h of
              -- handle ... with cases
              LamsNamedMatch' [] [([Pattern ()], Maybe (Term3 v PrintAnnotation),
  Term3 v PrintAnnotation)]
_ -> \Pretty SyntaxText
a Pretty SyntaxText
b -> Pretty SyntaxText
a Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
b
              Term3 v PrintAnnotation
_ -> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
        Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Control) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
          if Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
pb Bool -> Bool -> Bool
|| Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
ph
            then
              [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"handle" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pb,
                  Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"with" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hangHandler` Pretty SyntaxText
ph
                ]
            else
              [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.spaced
                [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"handle"
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pb
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"with"
                      Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hangHandler` Pretty SyntaxText
ph
                ]
      Delay' Term3 v PrintAnnotation
x
        | Match' Term3 v PrintAnnotation
_ [MatchCase () (Term3 v PrintAnnotation)]
_ <- Term3 v PrintAnnotation
x -> do
            Pretty SyntaxText
px <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
x
            let hang :: Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
hang = if Term3 v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term3 v PrintAnnotation
x then Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang else Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
            Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
Control) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
              Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"do" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hang` Pretty SyntaxText
px
        | Bool
otherwise -> do
            let (Imports
im0', [Pretty SyntaxText]
uses0) = Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
forall v.
(Var v, Ord v) =>
Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
calcImports Imports
im Term3 v PrintAnnotation
x
            let allowUses :: Bool
allowUses = Term3 v PrintAnnotation -> Bool
forall vt at ap v a. Term2 vt at ap v a -> Bool
isLet Term3 v PrintAnnotation
x Bool -> Bool -> Bool
|| (Precedence
p Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
Bottom)
            let im' :: Imports
im' = if Bool
allowUses then Imports
im0' else Imports
im
            let uses :: [Pretty SyntaxText]
uses = if Bool
allowUses then [Pretty SyntaxText]
uses0 else []
            let soft :: Bool
soft = Term3 v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term3 v PrintAnnotation
x Bool -> Bool -> Bool
&& [Pretty SyntaxText] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pretty SyntaxText]
uses Bool -> Bool -> Bool
&& Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
Annotation
            let hang :: Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
hang = if Bool
soft then Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang else Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
            Pretty SyntaxText
px <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im' DocLiteralContext
doc) Term3 v PrintAnnotation
x
            -- this makes sure we get proper indentation if `px` spills onto
            -- multiple lines, since `do` introduces layout block
            let indent :: Width
indent = Int -> Width
PP.Width (if Bool
soft then Int
2 else Int
0) Width -> Width -> Width
forall a. Num a => a -> a -> a
+ (if Bool
soft Bool -> Bool -> Bool
&& Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
Application then Width
1 else Width
0)
            Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
Control) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
              Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"do" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hang` [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText]
uses [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Width -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
PP.indentNAfterNewline Width
indent Pretty SyntaxText
px])
      List' Seq (Term3 v PrintAnnotation)
xs -> do
        let listLink :: Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
p = Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Reference -> Element Reference
forall r. r -> Element r
S.TypeReference Reference
Type.listRef) Pretty SyntaxText
p
        let comma :: Pretty SyntaxText
comma = Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
", " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
", ")
        Seq (Pretty SyntaxText)
pelems <- (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> Seq (Term3 v PrintAnnotation) -> m (Seq (Pretty SyntaxText))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse ((Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Width -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
PP.indentNAfterNewline Width
2) (m (Pretty SyntaxText) -> m (Pretty SyntaxText))
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> Term3 v PrintAnnotation
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Normal Imports
im DocLiteralContext
doc)) Seq (Term3 v PrintAnnotation)
xs
        let open :: Pretty SyntaxText
open = Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
"[" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
"[ "
        let close :: Pretty SyntaxText
close = Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
"]" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText
listLink Pretty SyntaxText
"]")
        pure $ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText
open Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Seq (Pretty SyntaxText) -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
comma Seq (Pretty SyntaxText)
pelems Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
close)
      If' Term3 v PrintAnnotation
cond Term3 v PrintAnnotation
t Term3 v PrintAnnotation
f ->
        do
          Pretty SyntaxText
pcond <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Control BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
cond
          Pretty SyntaxText
pt <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
t
          Pretty SyntaxText
pf <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
f
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Control) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
            if Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
pcond
              then
                [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                  [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"if" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pcond,
                    Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"then" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pt,
                    Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"else" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pf
                  ]
              else
                if Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
pt Bool -> Bool -> Bool
|| Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
pf
                  then
                    [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                      [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"if " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
pcond Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
" then" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pt,
                        Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"else" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pf
                      ]
                  else
                    [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.spaced
                      [ (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"if" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pcond) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
" then" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pt),
                        Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"else" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pf
                      ]
      LetBlock [LetBindings v (Term3 v PrintAnnotation)]
bs Term3 v PrintAnnotation
e ->
        let (Imports
im', [Pretty SyntaxText]
uses) = Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
forall v.
(Var v, Ord v) =>
Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
calcImports Imports
im Term3 v PrintAnnotation
term
         in AmbientContext
-> BlockContext
-> [LetBindings v (Term3 v PrintAnnotation)]
-> Term3 v PrintAnnotation
-> [Pretty SyntaxText]
-> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> BlockContext
-> [LetBindings v (Term3 v PrintAnnotation)]
-> Term3 v PrintAnnotation
-> [Pretty SyntaxText]
-> m (Pretty SyntaxText)
printLet AmbientContext
a {imports = im'} BlockContext
bc [LetBindings v (Term3 v PrintAnnotation)]
bs Term3 v PrintAnnotation
e [Pretty SyntaxText]
uses
      -- Some matches are rendered as a destructuring bind, like
      --   match foo with (a,b) -> blah
      -- becomes
      --   (a,b) = foo
      --   blah
      -- See `isDestructuringBind` definition.
      Match' Term3 v PrintAnnotation
scrutinee cs :: [MatchCase () (Term3 v PrintAnnotation)]
cs@[MatchCase Pattern ()
pat Maybe (Term3 v PrintAnnotation)
guard (AbsN' [v]
vs Term3 v PrintAnnotation
body)]
        | Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
<= Precedence
Control Bool -> Bool -> Bool
&& Term3 v PrintAnnotation
-> [MatchCase () (Term3 v PrintAnnotation)] -> Bool
forall v (f :: * -> *) a loc.
Ord v =>
Term f v a -> [MatchCase loc (Term f v a)] -> Bool
isDestructuringBind Term3 v PrintAnnotation
scrutinee [MatchCase () (Term3 v PrintAnnotation)]
cs -> do
            Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
            let letIntro :: Pretty SyntaxText -> Pretty SyntaxText
letIntro = case BlockContext
bc of
                  BlockContext
Block -> Pretty SyntaxText -> Pretty SyntaxText
forall a. a -> a
id
                  BlockContext
Normal -> \Pretty SyntaxText
x -> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"let" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
x
            Pretty SyntaxText
lhs <- do
              let (Pretty SyntaxText
lhs, [v]
_) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern ()
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern Env v
env.ppe (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Precedence
Application [v]
vs Pattern ()
pat
              Pretty SyntaxText
guard' <- Maybe (Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printGuard Maybe (Term3 v PrintAnnotation)
guard
              pure $ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group Pretty SyntaxText
lhs Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
guard'
            let eq :: Pretty (SyntaxText' r)
eq = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.BindingEquals Pretty (SyntaxText' r)
"="
            Pretty SyntaxText
rhs <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Bottom BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
scrutinee
            Pretty SyntaxText -> Pretty SyntaxText
letIntro (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Pretty SyntaxText
prettyBody <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Bottom BlockContext
Block Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
body
              pure $
                [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                  [ (Pretty SyntaxText
lhs Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
eq) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
rhs,
                    Pretty SyntaxText
prettyBody
                  ]
        where
          printGuard :: Maybe (Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printGuard Maybe (Term3 v PrintAnnotation)
Nothing = Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pretty SyntaxText
forall a. Monoid a => a
mempty
          printGuard (Just Term3 v PrintAnnotation
g') = do
            let ([v]
_, Term3 v PrintAnnotation
g) = Term3 v PrintAnnotation -> ([v], Term3 v PrintAnnotation)
forall (f :: * -> *) v a. Term f v a -> ([v], Term f v a)
ABT.unabs Term3 v PrintAnnotation
g'
            Pretty SyntaxText
prettyg <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Control BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
g
            pure $ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"| " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyg
      Match' Term3 v PrintAnnotation
scrutinee [MatchCase () (Term3 v PrintAnnotation)]
branches ->
        do
          Pretty SyntaxText
ps <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Control BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
scrutinee
          Pretty SyntaxText
pbs <- Imports
-> DocLiteralContext
-> [([Pattern ()], Maybe (Term3 v PrintAnnotation),
     Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
forall (m :: * -> *) v.
MonadPretty v m =>
Imports
-> DocLiteralContext
-> [MatchCase' () (Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
printCase Imports
im DocLiteralContext
doc ([MatchCase () (Term3 v PrintAnnotation)]
-> [([Pattern ()], Maybe (Term3 v PrintAnnotation),
     Term3 v PrintAnnotation)]
forall ann tm. [MatchCase ann tm] -> [MatchCase' ann tm]
arity1Branches [MatchCase () (Term3 v PrintAnnotation)]
branches) -- don't print with `cases` syntax
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Control) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
            if Pretty SyntaxText -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty SyntaxText
ps
              then
                [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                  [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"match " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
ps,
                    Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
" with" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pbs
                  ]
              else (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"match " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
ps Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
" with") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pbs
      Apps' Term3 v PrintAnnotation
f [Term3 v PrintAnnotation]
args -> Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText -> Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Term3 v PrintAnnotation
f m (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m (Pretty SyntaxText)
forall (f :: * -> *) s (m :: * -> *) a.
(Traversable f, IsString s, Applicative m) =>
(a -> m (Pretty s)) -> f a -> m (Pretty s)
PP.spacedTraverse (Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Application) [Term3 v PrintAnnotation]
args)
      Term3 v PrintAnnotation
t -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"error: " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (Term3 v PrintAnnotation -> String
forall a. Show a => a -> String
show Term3 v PrintAnnotation
t)
    where
      goNormal :: Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
prec Term3 v PrintAnnotation
tm = AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
prec BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
tm
      specialCases :: Term3 v PrintAnnotation
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> m (Pretty SyntaxText)
specialCases Term3 v PrintAnnotation
term Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go = do
        AmbientContext
-> Term3 v PrintAnnotation -> m (Maybe (Pretty SyntaxText))
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> Term3 v PrintAnnotation -> m (Maybe (Pretty SyntaxText))
prettyDoc2 AmbientContext
a Term3 v PrintAnnotation
term m (Maybe (Pretty SyntaxText))
-> (Maybe (Pretty SyntaxText) -> m (Pretty SyntaxText))
-> m (Pretty SyntaxText)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Pretty SyntaxText
d -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pretty SyntaxText
d
          Maybe (Pretty SyntaxText)
Nothing -> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> m (Pretty SyntaxText)
notDoc Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go
        where
          notDoc :: (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> m (Pretty SyntaxText)
notDoc Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go = do
            Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
            let -- This predicate controls which binary functions we render as infix
                -- operators. At the moment the policy is just to render symbolic
                -- operators as infix.
                binaryOpsPred :: Term3 v PrintAnnotation -> Bool
                binaryOpsPred :: Term3 v PrintAnnotation -> Bool
binaryOpsPred = \case
                  Ref' Reference
r -> HashQualified Name -> Bool
isSymbolic (HashQualified Name -> Bool) -> HashQualified Name -> Bool
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe (Reference -> Referent
Referent.Ref Reference
r)
                  Var' v
v -> HashQualified Name -> Bool
isSymbolic (HashQualified Name -> Bool) -> HashQualified Name -> Bool
forall a b. (a -> b) -> a -> b
$ v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar v
v
                  Term3 v PrintAnnotation
_ -> Bool
False
                -- Gets the precedence of an infix operator, if it has one.
                termPrecedence :: Term3 v PrintAnnotation -> Maybe Precedence
                termPrecedence :: Term3 v PrintAnnotation -> Maybe Precedence
termPrecedence = \case
                  Ref' Reference
r ->
                    HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName (PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe (Reference -> Referent
Referent.Ref Reference
r))
                      Maybe Name -> (Name -> Maybe Precedence) -> Maybe Precedence
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Precedence
operatorPrecedence
                        (Text -> Maybe Precedence)
-> (Name -> Text) -> Name -> Maybe Precedence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toEscapedText
                        (NameSegment -> Text) -> (Name -> NameSegment) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameSegment
Name.lastSegment
                  Var' v
v ->
                    HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName (v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar v
v)
                      Maybe Name -> (Name -> Maybe Precedence) -> Maybe Precedence
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Precedence
operatorPrecedence
                        (Text -> Maybe Precedence)
-> (Name -> Text) -> Name -> Maybe Precedence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toEscapedText
                        (NameSegment -> Text) -> (Name -> NameSegment) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameSegment
Name.lastSegment
                  Term3 v PrintAnnotation
_ -> Maybe Precedence
forall a. Maybe a
Nothing
                prettyBinaryApp :: AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
prettyBinaryApp AmbientContext
ctx Term3 v PrintAnnotation
term =
                  case (Term3 v PrintAnnotation
term, Term3 v PrintAnnotation -> Bool
binaryOpsPred) of
                    BinaryAppPred' Term3 v PrintAnnotation
f Term3 v PrintAnnotation
a Term3 v PrintAnnotation
b ->
                      let prec :: Maybe Precedence
prec = Term3 v PrintAnnotation -> Maybe Precedence
termPrecedence Term3 v PrintAnnotation
f
                          p :: Precedence
p = AmbientContext -> Precedence
precedence AmbientContext
ctx
                          im :: Imports
im = AmbientContext -> Imports
imports AmbientContext
ctx
                          doc :: DocLiteralContext
doc = AmbientContext -> DocLiteralContext
docContext AmbientContext
ctx
                       in case (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
unBinaryAppsPred' (Term3 v PrintAnnotation
term, Term3 v PrintAnnotation -> Bool
binaryOpsPred) of
                            -- Only render infix operators as a table
                            -- if there's more than one of the same
                            -- operator in a row.
                            Just (apps :: [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
apps@((Term3 v PrintAnnotation, Term3 v PrintAnnotation)
_ : (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
_ : [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
_), Term3 v PrintAnnotation
lastArg) -> do
                              Pretty SyntaxText
prettyLast <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
lastArg
                              Pretty SyntaxText
prettyApps <- [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> Pretty SyntaxText -> m (Pretty SyntaxText)
binaryApps [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
apps Pretty SyntaxText
prettyLast
                              pure $ Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) Pretty SyntaxText
prettyApps
                            Maybe
  ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
   Term3 v PrintAnnotation)
_ -> do
                              Pretty SyntaxText
prettyF <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext
-> InfixContext
-> Imports
-> DocLiteralContext
-> Bool
-> AmbientContext
AmbientContext Precedence
Application BlockContext
Normal InfixContext
Infix Imports
im DocLiteralContext
doc Bool
False) Term3 v PrintAnnotation
f
                              Pretty SyntaxText
prettyA <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
prettyBinaryApp (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
a
                              -- We increment the precedence for the right-hand side
                              -- since we want parens if the right-hand side is an
                              -- infix operator app with the same precedence as the
                              -- current operator.
                              Pretty SyntaxText
prettyB <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
prettyBinaryApp (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence
-> (Precedence -> Precedence) -> Maybe Precedence -> Precedence
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Precedence -> Precedence
increment Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
b
                              Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                                (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.indent Pretty SyntaxText
"  " (Pretty SyntaxText
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB))
                    (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
_ -> AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ctx Term3 v PrintAnnotation
term
                unBinaryAppsPred' ::
                  ( Term3 v PrintAnnotation,
                    Term3 v PrintAnnotation -> Bool
                  ) ->
                  Maybe
                    ( [ ( Term3 v PrintAnnotation,
                          Term3 v PrintAnnotation
                        )
                      ],
                      Term3 v PrintAnnotation
                    )
                unBinaryAppsPred' :: (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
unBinaryAppsPred' (Term3 v PrintAnnotation
t, Term3 v PrintAnnotation -> Bool
isInfix) =
                  Term3 v PrintAnnotation
-> (Term3 v PrintAnnotation -> Bool)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
go Term3 v PrintAnnotation
t Term3 v PrintAnnotation -> Bool
isInfix
                  where
                    go :: Term3 v PrintAnnotation
-> (Term3 v PrintAnnotation -> Bool)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
go Term3 v PrintAnnotation
t Term3 v PrintAnnotation -> Bool
pred =
                      case (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
-> Maybe
     (Term3 v PrintAnnotation, Term3 v PrintAnnotation,
      Term3 v PrintAnnotation)
forall vt at ap v a.
(Term2 vt at ap v a, Term2 vt at ap v a -> Bool)
-> Maybe
     (Term2 vt at ap v a, Term2 vt at ap v a, Term2 vt at ap v a)
unBinaryAppPred (Term3 v PrintAnnotation
t, Term3 v PrintAnnotation -> Bool
pred) of
                        Just (Term3 v PrintAnnotation
f, Term3 v PrintAnnotation
x, Term3 v PrintAnnotation
y) ->
                          -- We only chain together infix operators in a table
                          -- if they are literally the same operator.
                          let inChain :: Term3 v PrintAnnotation -> Bool
inChain Term3 v PrintAnnotation
g = Term3 v PrintAnnotation -> Bool
isInfix Term3 v PrintAnnotation
g Bool -> Bool -> Bool
&& (Term3 v PrintAnnotation
g Term3 v PrintAnnotation -> Term3 v PrintAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== Term3 v PrintAnnotation
f)
                              l :: Maybe
  ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
   Term3 v PrintAnnotation)
l = (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
unBinaryAppsPred' (Term3 v PrintAnnotation
x, Term3 v PrintAnnotation -> Bool
inChain)
                           in case Maybe
  ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
   Term3 v PrintAnnotation)
l of
                                Just ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
as, Term3 v PrintAnnotation
xLast) -> ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
 Term3 v PrintAnnotation)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
forall a. a -> Maybe a
Just ((Term3 v PrintAnnotation
xLast, Term3 v PrintAnnotation
f) (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
forall a. a -> [a] -> [a]
: [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
as, Term3 v PrintAnnotation
y)
                                Maybe
  ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
   Term3 v PrintAnnotation)
Nothing -> ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
 Term3 v PrintAnnotation)
-> Maybe
     ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
      Term3 v PrintAnnotation)
forall a. a -> Maybe a
Just ([(Term3 v PrintAnnotation
x, Term3 v PrintAnnotation
f)], Term3 v PrintAnnotation
y)
                        Maybe
  (Term3 v PrintAnnotation, Term3 v PrintAnnotation,
   Term3 v PrintAnnotation)
Nothing -> Maybe
  ([(Term3 v PrintAnnotation, Term3 v PrintAnnotation)],
   Term3 v PrintAnnotation)
forall a. Maybe a
Nothing

                -- Render a binary infix operator sequence, like [(a2, f2), (a1, f1)],
                -- meaning (a1 `f1` a2) `f2` (a3 rendered by the caller), producing
                -- "a1 `f1` a2 `f2`".  Except the operators are all symbolic, so we won't
                -- produce any backticks.  We build the result out from the right,
                -- starting at `f2`.
                binaryApps ::
                  [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)] ->
                  Pretty SyntaxText ->
                  m (Pretty SyntaxText)
                binaryApps :: [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> Pretty SyntaxText -> m (Pretty SyntaxText)
binaryApps [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
xs Pretty SyntaxText
last =
                  do
                    let xs' :: [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
xs' = [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
forall a. [a] -> [a]
reverse [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
xs
                    [Pretty SyntaxText]
psh <- [[Pretty SyntaxText]] -> [Pretty SyntaxText]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Pretty SyntaxText]] -> [Pretty SyntaxText])
-> m [[Pretty SyntaxText]] -> m [Pretty SyntaxText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term3 v PrintAnnotation, Term3 v PrintAnnotation)
 -> m [Pretty SyntaxText])
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> m [[Pretty SyntaxText]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Term3 v PrintAnnotation
 -> Term3 v PrintAnnotation -> m [Pretty SyntaxText])
-> (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
-> m [Pretty SyntaxText]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Precedence
-> Term3 v PrintAnnotation
-> Term3 v PrintAnnotation
-> m [Pretty SyntaxText]
r (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest))) (Int
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
forall a. Int -> [a] -> [a]
take Int
1 [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
xs')
                    [Pretty SyntaxText]
pst <- [[Pretty SyntaxText]] -> [Pretty SyntaxText]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Pretty SyntaxText]] -> [Pretty SyntaxText])
-> m [[Pretty SyntaxText]] -> m [Pretty SyntaxText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term3 v PrintAnnotation, Term3 v PrintAnnotation)
 -> m [Pretty SyntaxText])
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> m [[Pretty SyntaxText]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Term3 v PrintAnnotation
 -> Term3 v PrintAnnotation -> m [Pretty SyntaxText])
-> (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
-> m [Pretty SyntaxText]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Precedence
-> Term3 v PrintAnnotation
-> Term3 v PrintAnnotation
-> m [Pretty SyntaxText]
r (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest))) (Int
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
-> [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
forall a. Int -> [a] -> [a]
drop Int
1 [(Term3 v PrintAnnotation, Term3 v PrintAnnotation)]
xs')
                    let ps :: [Pretty SyntaxText]
ps = [Pretty SyntaxText]
psh [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText]
pst
                    let unbroken :: Pretty SyntaxText
unbroken = [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.spaced ([Pretty SyntaxText]
ps [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText
last])
                        broken :: Pretty SyntaxText
broken = Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang ([Pretty SyntaxText] -> Pretty SyntaxText
forall a. HasCallStack => [a] -> a
head [Pretty SyntaxText]
ps) (Pretty SyntaxText -> Pretty SyntaxText)
-> ([Pretty SyntaxText] -> Pretty SyntaxText)
-> [Pretty SyntaxText]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Pretty SyntaxText, Pretty SyntaxText)] -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
[(Pretty s, Pretty s)] -> Pretty s
PP.column2 ([(Pretty SyntaxText, Pretty SyntaxText)] -> Pretty SyntaxText)
-> ([Pretty SyntaxText]
    -> [(Pretty SyntaxText, Pretty SyntaxText)])
-> [Pretty SyntaxText]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty SyntaxText] -> [(Pretty SyntaxText, Pretty SyntaxText)]
forall {a}. IsString a => [a] -> [(a, a)]
psCols ([Pretty SyntaxText] -> Pretty SyntaxText)
-> [Pretty SyntaxText] -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. HasCallStack => [a] -> [a]
tail [Pretty SyntaxText]
ps [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText
last]
                    Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText
unbroken Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` Pretty SyntaxText
broken)
                  where
                    psCols :: [a] -> [(a, a)]
psCols [a]
ps = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
2 [a]
ps of
                      [a
x, a
y] -> (a
x, a
y) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [a] -> [(a, a)]
psCols (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
2 [a]
ps)
                      [a
x] -> [(a
x, a
"")]
                      [] -> []
                      [a]
_ -> [(a, a)]
forall a. HasCallStack => a
undefined
                    r :: Precedence
-> Term3 v PrintAnnotation
-> Term3 v PrintAnnotation
-> m [Pretty SyntaxText]
r Precedence
p Term3 v PrintAnnotation
a Term3 v PrintAnnotation
f =
                      [m (Pretty SyntaxText)] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
                        [ AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (if Term3 v PrintAnnotation -> Bool
forall v vt at ap a. (Var v, Ord v) => Term2 vt at ap v a -> Bool
isBlock Term3 v PrintAnnotation
a then Precedence
Top else Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe Precedence
p (Term3 v PrintAnnotation -> Maybe Precedence
termPrecedence Term3 v PrintAnnotation
f)) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
a,
                          AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext
-> InfixContext
-> Imports
-> DocLiteralContext
-> Bool
-> AmbientContext
AmbientContext Precedence
Application BlockContext
Normal InfixContext
Infix Imports
im DocLiteralContext
doc Bool
False) Term3 v PrintAnnotation
f
                        ]
            case (Term3 v PrintAnnotation
term, Term3 v PrintAnnotation -> Bool
binaryOpsPred) of
              (Term3 v PrintAnnotation
DD.Doc, Term3 v PrintAnnotation -> Bool
_)
                | DocLiteralContext
doc DocLiteralContext -> DocLiteralContext -> Bool
forall a. Eq a => a -> a -> Bool
== DocLiteralContext
MaybeDoc ->
                    if Term3 v PrintAnnotation -> Bool
forall v. Term3 v PrintAnnotation -> Bool
isDocLiteral Term3 v PrintAnnotation
term
                      then do
                        Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
                        pure (PrettyPrintEnv
-> Imports -> Term3 v PrintAnnotation -> Pretty SyntaxText
forall v a.
Var v =>
PrettyPrintEnv -> Imports -> Term3 v a -> Pretty SyntaxText
prettyDoc Env v
env.ppe Imports
im Term3 v PrintAnnotation
term)
                      else AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (AmbientContext
a {docContext = NoDoc}) Term3 v PrintAnnotation
term
              (TupleTerm' [Term3 v PrintAnnotation
x], Term3 v PrintAnnotation -> Bool
_) -> do
                let conRef :: Referent
conRef = Referent
DD.pairCtorRef
                Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
                let name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe Referent
conRef)
                let pair :: Pretty SyntaxText
pair = HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef)) HashQualified Name
name
                Pretty SyntaxText
x' <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Application BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
x
                Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                  Pretty SyntaxText
pair
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.spaced [Pretty SyntaxText
x', Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
DD.unitCtorRef) Pretty SyntaxText
"()"]
              (TupleTerm' [Term3 v PrintAnnotation]
xs, Term3 v PrintAnnotation -> Bool
_) -> do
                let tupleLink :: Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
p = Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Reference -> Element Reference
forall r. r -> Element r
S.TypeReference Reference
DD.pairRef) Pretty SyntaxText
p
                let comma :: Pretty SyntaxText
comma = Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
", " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
", ")
                [Pretty SyntaxText]
pelems <- (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Width -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
PP.indentNAfterNewline Width
2) (m (Pretty SyntaxText) -> m (Pretty SyntaxText))
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> Term3 v PrintAnnotation
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Annotation) [Term3 v PrintAnnotation]
xs
                let clist :: Pretty SyntaxText
clist = Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
comma [Pretty SyntaxText]
pelems
                let open :: Pretty SyntaxText
open = Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
"(" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
"( "
                let close :: Pretty SyntaxText
close = Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
")" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText
tupleLink Pretty SyntaxText
")")
                pure $ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText
open Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
clist Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
close)
              (App' f :: Term3 v PrintAnnotation
f@(Builtin' Text
"Any.Any") Term3 v PrintAnnotation
arg, Term3 v PrintAnnotation -> Bool
_) ->
                Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText -> Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Term3 v PrintAnnotation
f m (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Application Term3 v PrintAnnotation
arg)
              (DD.Rewrites' [Term3 v PrintAnnotation]
rs, Term3 v PrintAnnotation -> Bool
_) -> do
                let kw :: Pretty (SyntaxText' r)
kw = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword Pretty (SyntaxText' r)
"@rewrite"
                    arr :: Pretty (SyntaxText' r)
arr = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword Pretty (SyntaxText' r)
"==>"
                    control :: Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
control = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword
                    sub :: Pretty SyntaxText
-> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
sub Pretty SyntaxText
kw Term3 v PrintAnnotation
lhs = Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
" " ([Pretty SyntaxText] -> Pretty SyntaxText)
-> m [Pretty SyntaxText] -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m (Pretty SyntaxText)] -> m [Pretty SyntaxText]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
control Pretty SyntaxText
kw, Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Annotation Term3 v PrintAnnotation
lhs, Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
arr]
                    go :: Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go (DD.RewriteTerm' Term3 v PrintAnnotation
lhs Term3 v PrintAnnotation
rhs) = Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText -> Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pretty SyntaxText
-> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
sub Pretty SyntaxText
"term" Term3 v PrintAnnotation
lhs m (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Annotation Term3 v PrintAnnotation
rhs
                    go (DD.RewriteCase' Term3 v PrintAnnotation
lhs Term3 v PrintAnnotation
rhs) = Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText -> Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pretty SyntaxText
-> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
sub Pretty SyntaxText
"case" Term3 v PrintAnnotation
lhs m (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Annotation Term3 v PrintAnnotation
rhs
                    go (DD.RewriteSignature' [v]
vs Type v ()
lhs Type v ()
rhs) = do
                      Pretty SyntaxText
lhs <- Imports -> Int -> Type v () -> m (Pretty SyntaxText)
forall v a (m :: * -> *).
MonadPretty v m =>
Imports -> Int -> Type v a -> m (Pretty SyntaxText)
TypePrinter.pretty0 Imports
im Int
0 Type v ()
lhs
                      Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
" " (Pretty SyntaxText -> [Pretty SyntaxText]
stuff Pretty SyntaxText
lhs)) (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Imports -> Int -> Type v () -> m (Pretty SyntaxText)
forall v a (m :: * -> *).
MonadPretty v m =>
Imports -> Int -> Type v a -> m (Pretty SyntaxText)
TypePrinter.pretty0 Imports
im Int
0 Type v ()
rhs
                      where
                        stuff :: Pretty SyntaxText -> [Pretty SyntaxText]
stuff Pretty SyntaxText
lhs =
                          [Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
control Pretty SyntaxText
"signature"]
                            [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (v -> Text
forall v. Var v => v -> Text
Var.name v
v)) | v
v <- [v]
vs]
                            [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> (if [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
vs then [] else [Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TypeOperator Pretty SyntaxText
"."])
                            [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText
lhs, Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
arr]
                    go Term3 v PrintAnnotation
tm = Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Application Term3 v PrintAnnotation
tm
                Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
kw (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Pretty SyntaxText] -> Pretty SyntaxText)
-> m [Pretty SyntaxText] -> m (Pretty SyntaxText)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ((Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go [Term3 v PrintAnnotation]
rs)
              (Bytes' [Word64]
bs, Term3 v PrintAnnotation -> Bool
_) ->
                Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BytesLiteral Pretty SyntaxText
"0xs" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Bytes -> Pretty SyntaxText
forall a s. (Show a, IsString s) => a -> Pretty s
PP.shown ([Word8] -> Bytes
Bytes.fromWord8s ((Word64 -> Word8) -> [Word64] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word64]
bs))
              binApp :: (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
binApp@(BinaryAppPred' {}) -> do
                Pretty SyntaxText
v <- Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
prettyBinaryApp AmbientContext
a ((Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
-> Term3 v PrintAnnotation
forall a b. (a, b) -> a
fst (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
binApp)
                pure Pretty SyntaxText
v
              (And' Term3 v PrintAnnotation
a Term3 v PrintAnnotation
b, Term3 v PrintAnnotation -> Bool
_) -> do
                let prec :: Maybe Precedence
prec = Text -> Maybe Precedence
operatorPrecedence Text
"&&"
                    prettyF :: Pretty (SyntaxText' r)
prettyF = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword Pretty (SyntaxText' r)
"&&"
                Pretty SyntaxText
prettyA <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
a
                Pretty SyntaxText
prettyB <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
b
                Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                  (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB)
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.indent Pretty SyntaxText
"  " (Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB))
              (Or' Term3 v PrintAnnotation
a Term3 v PrintAnnotation
b, Term3 v PrintAnnotation -> Bool
_) -> do
                let prec :: Maybe Precedence
prec = Text -> Maybe Precedence
operatorPrecedence Text
"||"
                    prettyF :: Pretty (SyntaxText' r)
prettyF = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword Pretty (SyntaxText' r)
"||"
                Pretty SyntaxText
prettyA <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
a
                Pretty SyntaxText
prettyB <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Maybe Precedence
prec) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
b
                Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence -> Maybe Precedence -> Precedence
forall a. a -> Maybe a -> a
fromMaybe (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) Maybe Precedence
prec) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                  (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB)
                    Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
prettyA Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.indent Pretty SyntaxText
"  " (Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r)
prettyF Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyB))
              {-
              When a delayed computation block is passed to a function as the last argument
              in a context where the ambient precedence is low enough, we can elide parentheses
              around it and use a "soft hang" to put the `'let` on the same line as the function call.
              This looks nice.

                forkAt usEast 'let
                  x = thing1
                  y = thing2
                  ...

              instead of the ugly but effective

                forkAt
                  usEast
                  ('let
                    x = thing1
                    y = thing2
                    ...)
              -}
              (App' Term3 v PrintAnnotation
x (Constructor' (ConstructorReference Reference
DD.UnitRef Word64
0)), Term3 v PrintAnnotation -> Bool
_) | Term3 v PrintAnnotation -> Bool
forall vt at ap v a. Term2 vt at ap v a -> Bool
isLeaf Term3 v PrintAnnotation
x -> do
                Pretty SyntaxText
px <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (if Term3 v PrintAnnotation -> Bool
forall v vt at ap a. (Var v, Ord v) => Term2 vt at ap v a -> Bool
isBlock Term3 v PrintAnnotation
x then Precedence
Annotation else InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
x
                Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Prefix Bool -> Bool -> Bool
|| Term3 v PrintAnnotation -> Bool
forall v vt at ap a. (Var v, Ord v) => Term2 vt at ap v a -> Bool
isBlock Term3 v PrintAnnotation
x Bool -> Bool -> Bool
&& Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest)) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                  Pretty SyntaxText
px Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Unit (String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"()")
              (Apps' Term3 v PrintAnnotation
f ([Term3 v PrintAnnotation]
-> Maybe ([Term3 v PrintAnnotation], Term3 v PrintAnnotation)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc -> Just ([Term3 v PrintAnnotation]
args, Term3 v PrintAnnotation
lastArg)), Term3 v PrintAnnotation -> Bool
_)
                | Term3 v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term3 v PrintAnnotation
lastArg -> do
                    Pretty SyntaxText
fun <- Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Highest) Term3 v PrintAnnotation
f
                    [Pretty SyntaxText]
args' <- (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Application) [Term3 v PrintAnnotation]
args
                    Pretty SyntaxText
lastArg' <- Precedence -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
goNormal Precedence
Annotation Term3 v PrintAnnotation
lastArg
                    let softTab :: Pretty SyntaxText
softTab = Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> (Pretty SyntaxText
"" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` Pretty SyntaxText
"  ")
                    Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= (InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest)) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                      Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
softTab (Pretty SyntaxText
fun Pretty SyntaxText -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. a -> [a] -> [a]
: [Pretty SyntaxText]
args') Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
softTab)) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
lastArg')
              (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
_other -> case (Term3 v PrintAnnotation
term, Term3 v PrintAnnotation -> Bool
nonForcePred) of
                AppsPred' Term3 v PrintAnnotation
f [Term3 v PrintAnnotation]
args ->
                  Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                    Pretty SyntaxText
f' <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Application BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
f
                    Pretty SyntaxText
args' <- (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m (Pretty SyntaxText)
forall (f :: * -> *) s (m :: * -> *) a.
(Traversable f, IsString s, Applicative m) =>
(a -> m (Pretty s)) -> f a -> m (Pretty s)
PP.spacedTraverse (AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Application BlockContext
Normal Imports
im DocLiteralContext
doc)) [Term3 v PrintAnnotation]
args
                    pure $ Pretty SyntaxText
f' Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
args'
                (Term3 v PrintAnnotation, Term3 v PrintAnnotation -> Bool)
_other -> case (Term3 v PrintAnnotation
term, \v
v -> v -> Bool
Var v => v -> Bool
nonUnitArgPred v
v Bool -> Bool -> Bool
&& Bool -> Bool
not (Term3 v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isDelay Term3 v PrintAnnotation
term)) of
                  (LamsNamedMatch' [] [([Pattern ()], Maybe (Term3 v PrintAnnotation),
  Term3 v PrintAnnotation)]
branches, v -> Bool
_) -> do
                    Pretty SyntaxText
pbs <- Imports
-> DocLiteralContext
-> [([Pattern ()], Maybe (Term3 v PrintAnnotation),
     Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
forall (m :: * -> *) v.
MonadPretty v m =>
Imports
-> DocLiteralContext
-> [MatchCase' () (Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
printCase Imports
im DocLiteralContext
doc [([Pattern ()], Maybe (Term3 v PrintAnnotation),
  Term3 v PrintAnnotation)]
branches
                    Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                      Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"cases") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pbs
                  LamsNamedPred' [v]
vs Term3 v PrintAnnotation
body -> do
                    Pretty SyntaxText
prettyBody <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Control BlockContext
Normal Imports
im DocLiteralContext
doc) Term3 v PrintAnnotation
body
                    let hang :: Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
hang = case Term3 v PrintAnnotation
body of
                          Delay' (Lets' [(Bool, v, Term3 v PrintAnnotation)]
_ Term3 v PrintAnnotation
_) -> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang
                          Lets' [(Bool, v, Term3 v PrintAnnotation)]
_ Term3 v PrintAnnotation
_ -> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang
                          Match' Term3 v PrintAnnotation
_ [MatchCase () (Term3 v PrintAnnotation)]
_ -> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang
                          Term3 v PrintAnnotation
_ -> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
                    Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= InfixPrecedence -> Precedence
InfixOp InfixPrecedence
Lowest) (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
                      Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group ([v] -> Pretty SyntaxText
varList [v]
vs Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
" ->") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hang` Pretty SyntaxText
prettyBody
                  (Term3 v PrintAnnotation, v -> Bool)
_other -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Term3 v PrintAnnotation
term

      isDelay :: Term2 vt at ap v a -> Bool
isDelay (Delay' Term2 vt at ap v a
_) = Bool
True
      isDelay Term2 vt at ap v a
_ = Bool
False
      sepList' :: (a -> f b) -> b -> [a] -> f b
sepList' a -> f b
f b
sep [a]
xs = [b] -> b
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([b] -> b) -> ([b] -> [b]) -> [b] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [b] -> [b]
forall a. a -> [a] -> [a]
intersperse b
sep ([b] -> b) -> f [b] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> f b
f [a]
xs
      varList :: [v] -> Pretty SyntaxText
varList = Identity (Pretty SyntaxText) -> Pretty SyntaxText
forall a. Identity a -> a
runIdentity (Identity (Pretty SyntaxText) -> Pretty SyntaxText)
-> ([v] -> Identity (Pretty SyntaxText))
-> [v]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Identity (Pretty SyntaxText))
-> Pretty SyntaxText -> [v] -> Identity (Pretty SyntaxText)
forall {f :: * -> *} {b} {a}.
(Monoid b, Applicative f) =>
(a -> f b) -> b -> [a] -> f b
sepList' (Pretty SyntaxText -> Identity (Pretty SyntaxText)
forall a. a -> Identity a
Identity (Pretty SyntaxText -> Identity (Pretty SyntaxText))
-> (v -> Pretty SyntaxText) -> v -> Identity (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (Text -> Pretty SyntaxText)
-> (v -> Text) -> v -> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name) Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak

      nonForcePred :: Term3 v PrintAnnotation -> Bool
      nonForcePred :: Term3 v PrintAnnotation -> Bool
nonForcePred = \case
        Constructor' (ConstructorReference Reference
DD.DocRef Word64
_) -> Bool
False
        Term3 v PrintAnnotation
_ -> Bool
True

      nonUnitArgPred :: (Var v) => v -> Bool
      nonUnitArgPred :: Var v => v -> Bool
nonUnitArgPred v
v = v -> Text
forall v. Var v => v -> Text
Var.name v
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"()"

printLet ::
  (MonadPretty v m) =>
  AmbientContext ->
  BlockContext ->
  [LetBindings v (Term3 v PrintAnnotation)] ->
  Term3 v PrintAnnotation ->
  [Pretty SyntaxText] ->
  m (Pretty SyntaxText)
printLet :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> BlockContext
-> [LetBindings v (Term3 v PrintAnnotation)]
-> Term3 v PrintAnnotation
-> [Pretty SyntaxText]
-> m (Pretty SyntaxText)
printLet AmbientContext
context BlockContext
sc [LetBindings v (Term3 v PrintAnnotation)]
bs Term3 v PrintAnnotation
e [Pretty SyntaxText]
uses = do
  [[Pretty SyntaxText]]
bs <- (LetBindings v (Term3 v PrintAnnotation) -> m [Pretty SyntaxText])
-> [LetBindings v (Term3 v PrintAnnotation)]
-> m [[Pretty SyntaxText]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (AmbientContext
-> LetBindings v (Term3 v PrintAnnotation) -> m [Pretty SyntaxText]
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> LetBindings v (Term3 v PrintAnnotation) -> m [Pretty SyntaxText]
printLetBindings AmbientContext
bindingContext) [LetBindings v (Term3 v PrintAnnotation)]
bs
  [Pretty SyntaxText]
body <- Term3 v PrintAnnotation -> m [Pretty SyntaxText]
body Term3 v PrintAnnotation
e
  Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (BlockContext
sc BlockContext -> BlockContext -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockContext
Block Bool -> Bool -> Bool
&& AmbientContext
context.precedence Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Top) (Pretty SyntaxText -> Pretty SyntaxText)
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
letIntro (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText]
uses [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [[Pretty SyntaxText]] -> [Pretty SyntaxText]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Pretty SyntaxText]]
bs [Pretty SyntaxText] -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. Semigroup a => a -> a -> a
<> [Pretty SyntaxText]
body)
  where
    bindingContext :: AmbientContext
    bindingContext :: AmbientContext
bindingContext =
      Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Bottom BlockContext
Normal AmbientContext
context.imports AmbientContext
context.docContext
    body :: Term3 v PrintAnnotation -> m [Pretty SyntaxText]
body = \case
      Constructor' (ConstructorReference Reference
DD.UnitRef Word64
0) | AmbientContext
context.elideUnit -> [Pretty SyntaxText] -> m [Pretty SyntaxText]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Term3 v PrintAnnotation
e -> Pretty SyntaxText -> [Pretty SyntaxText]
forall a. a -> [a]
List.singleton (Pretty SyntaxText -> [Pretty SyntaxText])
-> m (Pretty SyntaxText) -> m [Pretty SyntaxText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Normal AmbientContext
context.imports AmbientContext
context.docContext) Term3 v PrintAnnotation
e
    letIntro :: Pretty SyntaxText -> Pretty SyntaxText
letIntro = case BlockContext
sc of
      BlockContext
Block -> Pretty SyntaxText -> Pretty SyntaxText
forall a. a -> a
id
      BlockContext
Normal -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"let" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang`)

printLetBindings ::
  (MonadPretty v m) =>
  AmbientContext ->
  LetBindings v (Term3 v PrintAnnotation) ->
  m [Pretty SyntaxText]
printLetBindings :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> LetBindings v (Term3 v PrintAnnotation) -> m [Pretty SyntaxText]
printLetBindings AmbientContext
context = \case
  LetBindings [(v, Term3 v PrintAnnotation)]
bindings -> ((v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText))
-> [(v, Term3 v PrintAnnotation)] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (AmbientContext
-> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetBinding AmbientContext
context) [(v, Term3 v PrintAnnotation)]
bindings
  LetrecBindings [(v, Term3 v PrintAnnotation)]
bindings ->
    let boundVars :: [v]
boundVars = ((v, Term3 v PrintAnnotation) -> v)
-> [(v, Term3 v PrintAnnotation)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, Term3 v PrintAnnotation) -> v
forall a b. (a, b) -> a
fst [(v, Term3 v PrintAnnotation)]
bindings
     in ((v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText))
-> [(v, Term3 v PrintAnnotation)] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (AmbientContext
-> [v] -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> [v] -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetrecBinding AmbientContext
context [v]
boundVars) [(v, Term3 v PrintAnnotation)]
bindings

printLetBinding :: (MonadPretty v m) => AmbientContext -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetBinding :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetBinding AmbientContext
context (v
v, Term3 v PrintAnnotation
binding)
  | v -> Bool
forall v. Var v => v -> Bool
Var.isAction v
v = AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
context Term3 v PrintAnnotation
binding
  | Bool
otherwise =
      PrettyBinding -> Pretty SyntaxText
renderPrettyBinding (PrettyBinding -> Pretty SyntaxText)
-> m PrettyBinding -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> m PrettyBinding -> m PrettyBinding
forall v (m :: * -> *) a. MonadPretty v m => v -> m a -> m a
withBoundTerm v
v (AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
prettyBinding0' AmbientContext
context (v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar v
v1) Term3 v PrintAnnotation
binding)
  where
    v1 :: v
v1 = v -> v
forall v. Var v => v -> v
Var.reset v
v

printLetrecBinding :: (MonadPretty v m) => AmbientContext -> [v] -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetrecBinding :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> [v] -> (v, Term3 v PrintAnnotation) -> m (Pretty SyntaxText)
printLetrecBinding AmbientContext
context [v]
vs (v
v, Term3 v PrintAnnotation
binding) =
  PrettyBinding -> Pretty SyntaxText
renderPrettyBinding (PrettyBinding -> Pretty SyntaxText)
-> m PrettyBinding -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v] -> m PrettyBinding -> m PrettyBinding
forall v (m :: * -> *) a. MonadPretty v m => [v] -> m a -> m a
withBoundTerms [v]
vs (AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
prettyBinding0' AmbientContext
context (v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar (v -> v
forall v. Var v => v -> v
Var.reset v
v)) Term3 v PrintAnnotation
binding)

prettyPattern ::
  forall v loc.
  (Var v) =>
  PrettyPrintEnv ->
  AmbientContext ->
  Precedence ->
  [v] ->
  Pattern loc ->
  (Pretty SyntaxText, [v])
-- vs is the list of pattern variables used by the pattern, plus possibly a
-- tail of variables it doesn't use.  This tail is the second component of
-- the return value.
prettyPattern :: forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n c :: AmbientContext
c@AmbientContext {$sel:imports:AmbientContext :: AmbientContext -> Imports
imports = Imports
im} Precedence
p [v]
vs Pattern loc
patt = case Pattern loc
patt of
  Pattern.Char loc
_ Char
c ->
    ( Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.CharLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
        String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ case Char -> Maybe Char
showEscapeChar Char
c of
          Just Char
c -> String
"?\\" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
          Maybe Char
Nothing -> Char
'?' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char
c],
      [v]
vs
    )
  Pattern.Unbound loc
_ -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> s
l String
"_", [v]
vs)
  Pattern.Var loc
_ ->
    case [v]
vs of
      (v
v : [v]
tail_vs) -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ v -> String
forall v. Var v => v -> String
Var.nameStr (v -> v
forall v. Var v => v -> v
Var.reset v
v), [v]
tail_vs)
      [v]
_ -> String -> (Pretty SyntaxText, [v])
forall a. HasCallStack => String -> a
error String
"prettyPattern: Expected at least one var"
  Pattern.Boolean loc
_ Bool
b -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BooleanLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ if Bool
b then String -> Pretty SyntaxText
forall s. IsString s => String -> s
l String
"true" else String -> Pretty SyntaxText
forall s. IsString s => String -> s
l String
"false", [v]
vs)
  Pattern.Int loc
_ Int64
i -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ (if Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 then String -> Pretty SyntaxText
forall s. IsString s => String -> s
l String
"+" else Pretty SyntaxText
forall a. Monoid a => a
mempty) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (Int64 -> String
forall a. Show a => a -> String
show Int64
i), [v]
vs)
  Pattern.Nat loc
_ Word64
u -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show Word64
u, [v]
vs)
  Pattern.Float loc
_ Double
f -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.NumericLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
f, [v]
vs)
  Pattern.Text loc
_ Text
t -> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TextLiteral (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
t, [v]
vs)
  TuplePattern [Pattern loc]
pats
    | [Pattern loc] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern loc]
pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 ->
        let ([Pretty SyntaxText]
pats_printed, [v]
tail_vs) = Precedence -> [v] -> [Pattern loc] -> ([Pretty SyntaxText], [v])
patterns Precedence
Bottom [v]
vs [Pattern loc]
pats
         in ([Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.parenthesizeCommas [Pretty SyntaxText]
pats_printed, [v]
tail_vs)
  Pattern.Constructor loc
_ ConstructorReference
ref [] ->
    ((Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef) HashQualified Name
name, [v]
vs)
    where
      name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n Referent
conRef
      conRef :: Referent
conRef = ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
CT.Data
  Pattern.Constructor loc
_ ConstructorReference
ref [Pattern loc]
pats ->
    let (Pretty SyntaxText
pats_printed, [v]
tail_vs) = Precedence
-> Pretty SyntaxText
-> [v]
-> [Pattern loc]
-> (Pretty SyntaxText, [v])
patternsSep Precedence
Application Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak [v]
vs [Pattern loc]
pats
        name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n Referent
conRef
        conRef :: Referent
conRef = ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
CT.Data
     in ( Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Application) (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
            (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef) HashQualified Name
name
              Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
pats_printed,
          [v]
tail_vs
        )
  Pattern.As loc
_ Pattern loc
pat ->
    case [v]
vs of
      (v
v : [v]
tail_vs) ->
        let (Pretty SyntaxText
printed, [v]
eventual_tail) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c Precedence
Prefix [v]
tail_vs Pattern loc
pat
         in (Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
Prefix) (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (String -> Pretty SyntaxText
forall s. IsString s => String -> s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ v -> String
forall v. Var v => v -> String
Var.nameStr (v -> v
forall v. Var v => v -> v
Var.reset v
v)) Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar (String -> Pretty SyntaxText
forall s. IsString s => String -> s
l String
"@") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
printed), [v]
eventual_tail)
      [v]
_ -> String -> (Pretty SyntaxText, [v])
forall a. HasCallStack => String -> a
error String
"prettyPattern: Expected at least one var"
  Pattern.EffectPure loc
_ Pattern loc
pat ->
    let (Pretty SyntaxText
printed, [v]
eventual_tail) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c Precedence
Bottom [v]
vs Pattern loc
pat
     in (Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
" " [Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"{", Pretty SyntaxText
printed, Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"}"], [v]
eventual_tail)
  Pattern.EffectBind loc
_ ConstructorReference
ref [Pattern loc]
pats Pattern loc
k_pat ->
    let (Pretty SyntaxText
pats_printed, [v]
tail_vs) = Precedence
-> Pretty SyntaxText
-> [v]
-> [Pattern loc]
-> (Pretty SyntaxText, [v])
patternsSep Precedence
Application Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak [v]
vs [Pattern loc]
pats
        (Pretty SyntaxText
k_pat_printed, [v]
eventual_tail) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c Precedence
Annotation [v]
tail_vs Pattern loc
k_pat
        name :: HashQualified Name
name = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> HashQualified Name)
-> HashQualified Name -> HashQualified Name
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n Referent
conRef
        conRef :: Referent
conRef = ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
CT.Effect
     in ( Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group
            ( Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
" " ([Pretty SyntaxText] -> Pretty SyntaxText)
-> ([Pretty SyntaxText] -> [Pretty SyntaxText])
-> [Pretty SyntaxText]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty SyntaxText] -> [Pretty SyntaxText]
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> [Pretty s]
PP.nonEmpty ([Pretty SyntaxText] -> Pretty SyntaxText)
-> [Pretty SyntaxText] -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
                [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"{",
                  (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
conRef)) HashQualified Name
name,
                  Pretty SyntaxText
pats_printed,
                  Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"->",
                  Pretty SyntaxText
k_pat_printed,
                  Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"}"
                ]
            ),
          [v]
eventual_tail
        )
  Pattern.SequenceLiteral loc
_ [Pattern loc]
pats ->
    let (Pretty SyntaxText
pats_printed, [v]
tail_vs) = Precedence
-> Pretty SyntaxText
-> [v]
-> [Pattern loc]
-> (Pretty SyntaxText, [v])
patternsSep Precedence
Bottom (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
", ") [v]
vs [Pattern loc]
pats
     in (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"[" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
pats_printed Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"]", [v]
tail_vs)
  Pattern.SequenceOp loc
_ Pattern loc
l SeqOp
op Pattern loc
r ->
    let (Pretty SyntaxText
pl, [v]
lvs) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c Precedence
p [v]
vs Pattern loc
l
        (Pretty SyntaxText
pr, [v]
rvs) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c (Precedence -> Precedence
increment Precedence
p) [v]
lvs Pattern loc
r
        f :: Precedence -> Pretty SyntaxText -> (Pretty SyntaxText, [v])
f Precedence
i Pretty SyntaxText
s = (Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren (Precedence
p Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
i) (Pretty SyntaxText
pl Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (SeqOp -> Element Reference
forall r. SeqOp -> Element r
S.Op SeqOp
op) Pretty SyntaxText
s Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
pr), [v]
rvs)
     in case SeqOp
op of
          SeqOp
Pattern.Cons -> Precedence -> Pretty SyntaxText -> (Pretty SyntaxText, [v])
f Precedence
Annotation Pretty SyntaxText
"+:"
          SeqOp
Pattern.Snoc -> Precedence -> Pretty SyntaxText -> (Pretty SyntaxText, [v])
f Precedence
Annotation Pretty SyntaxText
":+"
          SeqOp
Pattern.Concat -> Precedence -> Pretty SyntaxText -> (Pretty SyntaxText, [v])
f Precedence
Annotation Pretty SyntaxText
"++"
  where
    l :: (IsString s) => String -> s
    l :: forall s. IsString s => String -> s
l = String -> s
forall s. IsString s => String -> s
fromString
    patterns :: Precedence -> [v] -> [Pattern loc] -> ([Pretty SyntaxText], [v])
patterns Precedence
p [v]
vs (Pattern loc
pat : [Pattern loc]
pats) =
      let (Pretty SyntaxText
printed, [v]
tail_vs) =
            PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
n AmbientContext
c Precedence
p [v]
vs Pattern loc
pat
          ([Pretty SyntaxText]
rest_printed, [v]
eventual_tail) = Precedence -> [v] -> [Pattern loc] -> ([Pretty SyntaxText], [v])
patterns Precedence
p [v]
tail_vs [Pattern loc]
pats
       in (Pretty SyntaxText
printed Pretty SyntaxText -> [Pretty SyntaxText] -> [Pretty SyntaxText]
forall a. a -> [a] -> [a]
: [Pretty SyntaxText]
rest_printed, [v]
eventual_tail)
    patterns Precedence
_ [v]
vs [] = ([], [v]
vs)
    patternsSep :: Precedence
-> Pretty SyntaxText
-> [v]
-> [Pattern loc]
-> (Pretty SyntaxText, [v])
patternsSep Precedence
p Pretty SyntaxText
sep [v]
vs [Pattern loc]
pats = case Precedence -> [v] -> [Pattern loc] -> ([Pretty SyntaxText], [v])
patterns Precedence
p [v]
vs [Pattern loc]
pats of
      ([Pretty SyntaxText]
printed, [v]
tail_vs) -> (Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep Pretty SyntaxText
sep [Pretty SyntaxText]
printed, [v]
tail_vs)

type MatchCase' ann tm = ([Pattern ann], Maybe tm, tm)

arity1Branches :: [MatchCase ann tm] -> [MatchCase' ann tm]
arity1Branches :: forall ann tm. [MatchCase ann tm] -> [MatchCase' ann tm]
arity1Branches [MatchCase ann tm]
bs = [([Pattern ann
pat], Maybe tm
guard, tm
body) | MatchCase Pattern ann
pat Maybe tm
guard tm
body <- [MatchCase ann tm]
bs]

-- Groups adjacent cases with the same pattern together,
-- for easier pretty-printing, for instance:
--
--   Foo x y | blah1 x -> body1
--   Foo x y | blah2 y -> body2
--
-- becomes
--
--   Foo x y, [x,y], [(blah1 x, body1), (blah2 y, body2)]
groupCases ::
  (Ord v) =>
  [MatchCase' () (Term3 v ann)] ->
  [([Pattern ()], [v], [(Maybe (Term3 v ann), ([v], Term3 v ann))])]
groupCases :: forall v ann.
Ord v =>
[MatchCase' () (Term3 v ann)]
-> [([Pattern ()], [v],
     [(Maybe (Term3 v ann), ([v], Term3 v ann))])]
groupCases = \cases
    [] -> []
    ms :: [MatchCase' () (Term3 v ann)]
ms@(([Pattern ()]
p1, Maybe (Term3 v ann)
_, AbsN' [v]
vs1 Term3 v ann
_) : [MatchCase' () (Term3 v ann)]
_) -> ([Pattern ()], [v])
-> [(Maybe (Term3 v ann), ([v], Term3 v ann))]
-> [MatchCase' () (Term3 v ann)]
-> [([Pattern ()], [v],
     [(Maybe (Term3 v ann), ([v], Term3 v ann))])]
forall {v} {a}.
Ord v =>
([Pattern ()], [v])
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
go ([Pattern ()]
p1, [v]
vs1) [] [MatchCase' () (Term3 v ann)]
ms
  where
    go :: ([Pattern ()], [v])
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
go ([Pattern ()]
p0, [v]
vs0) [(Maybe (Term3 v a), ([v], Term3 v a))]
acc [] = [([Pattern ()]
p0, [v]
vs0, [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
forall a. [a] -> [a]
reverse [(Maybe (Term3 v a), ([v], Term3 v a))]
acc)]
    go ([Pattern ()]
p0, [v]
vs0) [(Maybe (Term3 v a), ([v], Term3 v a))]
acc ms :: [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
ms@(([Pattern ()]
p1, Maybe (Term3 v a)
g1, AbsN' [v]
vs Term3 v a
body) : [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
tl)
      | [Pattern ()]
p0 [Pattern ()] -> [Pattern ()] -> Bool
forall a. Eq a => a -> a -> Bool
== [Pattern ()]
p1 Bool -> Bool -> Bool
&& [v]
vs [v] -> [v] -> Bool
forall a. Eq a => a -> a -> Bool
== [v]
vs0 = ([Pattern ()], [v])
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
go ([Pattern ()]
p0, [v]
vs0) ((Maybe (Term3 v a)
g1, ([v]
vs, Term3 v a
body)) (Maybe (Term3 v a), ([v], Term3 v a))
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
forall a. a -> [a] -> [a]
: [(Maybe (Term3 v a), ([v], Term3 v a))]
acc) [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
tl
      | Bool
otherwise = ([Pattern ()]
p0, [v]
vs0, [(Maybe (Term3 v a), ([v], Term3 v a))]
-> [(Maybe (Term3 v a), ([v], Term3 v a))]
forall a. [a] -> [a]
reverse [(Maybe (Term3 v a), ([v], Term3 v a))]
acc) ([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
forall a. a -> [a] -> [a]
: [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
-> [([Pattern ()], [v], [(Maybe (Term3 v a), ([v], Term3 v a))])]
forall v ann.
Ord v =>
[MatchCase' () (Term3 v ann)]
-> [([Pattern ()], [v],
     [(Maybe (Term3 v ann), ([v], Term3 v ann))])]
groupCases [([Pattern ()], Maybe (Term3 v a), Term3 v a)]
ms

printCase ::
  forall m v.
  (MonadPretty v m) =>
  Imports ->
  DocLiteralContext ->
  [MatchCase' () (Term3 v PrintAnnotation)] ->
  m (Pretty SyntaxText)
printCase :: forall (m :: * -> *) v.
MonadPretty v m =>
Imports
-> DocLiteralContext
-> [MatchCase' () (Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
printCase Imports
im DocLiteralContext
doc [MatchCase' () (Term (F v () ()) v PrintAnnotation)]
ms =
  Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
PP.orElse
    (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText -> Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText] -> Pretty SyntaxText)
-> ([(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
    -> [Pretty SyntaxText])
-> [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
-> [Pretty SyntaxText]
forall {r}.
Eq r =>
Bool
-> [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
     [Pretty (SyntaxText' r)])]
-> [Pretty (SyntaxText' r)]
alignGrid Bool
True ([(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
 -> Pretty SyntaxText)
-> m [(Pretty SyntaxText, [Pretty SyntaxText],
       [Pretty SyntaxText])]
-> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
grid)
    m (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText] -> Pretty SyntaxText)
-> ([(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
    -> [Pretty SyntaxText])
-> [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
-> [Pretty SyntaxText]
forall {r}.
Eq r =>
Bool
-> [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
     [Pretty (SyntaxText' r)])]
-> [Pretty (SyntaxText' r)]
alignGrid Bool
False ([(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
 -> Pretty SyntaxText)
-> m [(Pretty SyntaxText, [Pretty SyntaxText],
       [Pretty SyntaxText])]
-> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
grid)
  where
    justify :: [(Pretty s, [a], [b])] -> [(Pretty s, [(a, b)])]
justify [(Pretty s, [a], [b])]
rows =
      [Pretty s] -> [[(a, b)]] -> [(Pretty s, [(a, b)])]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Pretty s, Pretty s) -> Pretty s)
-> [(Pretty s, Pretty s)] -> [Pretty s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty s, Pretty s) -> Pretty s
forall a b. (a, b) -> a
fst ([(Pretty s, Pretty s)] -> [Pretty s])
-> ([(Pretty s, Maybe (Pretty s))] -> [(Pretty s, Pretty s)])
-> [(Pretty s, Maybe (Pretty s))]
-> [Pretty s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Pretty s, Maybe (Pretty s))] -> [(Pretty s, Pretty s)]
forall s.
(ListLike s Char, IsString s) =>
[(Pretty s, Maybe (Pretty s))] -> [(Pretty s, Pretty s)]
PP.align' ([(Pretty s, Maybe (Pretty s))] -> [Pretty s])
-> [(Pretty s, Maybe (Pretty s))] -> [Pretty s]
forall a b. (a -> b) -> a -> b
$ ((Pretty s, [a], [b]) -> (Pretty s, Maybe (Pretty s)))
-> [(Pretty s, [a], [b])] -> [(Pretty s, Maybe (Pretty s))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty s, [a], [b]) -> (Pretty s, Maybe (Pretty s))
forall {a} {a} {b} {c}. IsString a => (a, b, c) -> (a, Maybe a)
alignPatterns [(Pretty s, [a], [b])]
rows) ([[(a, b)]] -> [(Pretty s, [(a, b)])])
-> [[(a, b)]] -> [(Pretty s, [(a, b)])]
forall a b. (a -> b) -> a -> b
$ ((Pretty s, [a], [b]) -> [(a, b)])
-> [(Pretty s, [a], [b])] -> [[(a, b)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty s, [a], [b]) -> [(a, b)]
forall {a} {a} {b}. (a, [a], [b]) -> [(a, b)]
gbs [(Pretty s, [a], [b])]
rows
      where
        alignPatterns :: (a, b, c) -> (a, Maybe a)
alignPatterns (a
p, b
_, c
_) = (a
p, a -> Maybe a
forall a. a -> Maybe a
Just a
"")
        gbs :: (a, [a], [b]) -> [(a, b)]
gbs (a
_, [a]
gs, [b]
bs) = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
gs [b]
bs
    nojustify :: [(a, [a], [b])] -> [(a, [(a, b)])]
nojustify = ((a, [a], [b]) -> (a, [(a, b)]))
-> [(a, [a], [b])] -> [(a, [(a, b)])]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a], [b]) -> (a, [(a, b)])
forall {a} {a} {b}. (a, [a], [b]) -> (a, [(a, b)])
f
      where
        f :: (a, [a], [b]) -> (a, [(a, b)])
f (a
p, [a]
gs, [b]
bs) = (a
p, [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
gs [b]
bs)
    alignGrid :: Bool
-> [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
     [Pretty (SyntaxText' r)])]
-> [Pretty (SyntaxText' r)]
alignGrid Bool
alignArrows [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
  [Pretty (SyntaxText' r)])]
grid =
      ((Pretty (SyntaxText' r),
  [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])
 -> Pretty (SyntaxText' r))
-> [(Pretty (SyntaxText' r),
     [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])]
-> [Pretty (SyntaxText' r)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pretty (SyntaxText' r),
 [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])
-> Pretty (SyntaxText' r)
alignCase ([(Pretty (SyntaxText' r),
   [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])]
 -> [Pretty (SyntaxText' r)])
-> [(Pretty (SyntaxText' r),
     [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])]
-> [Pretty (SyntaxText' r)]
forall a b. (a -> b) -> a -> b
$ if Bool
alignArrows then [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
  [Pretty (SyntaxText' r)])]
-> [(Pretty (SyntaxText' r),
     [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])]
forall {s} {a} {b}.
(Item s ~ Char, ListLike s Char, IsString s) =>
[(Pretty s, [a], [b])] -> [(Pretty s, [(a, b)])]
justify [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
  [Pretty (SyntaxText' r)])]
grid else [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
  [Pretty (SyntaxText' r)])]
-> [(Pretty (SyntaxText' r),
     [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])]
forall {a} {a} {b}. [(a, [a], [b])] -> [(a, [(a, b)])]
nojustify [(Pretty (SyntaxText' r), [Pretty (SyntaxText' r)],
  [Pretty (SyntaxText' r)])]
grid
      where
        alignCase :: (Pretty (SyntaxText' r),
 [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))])
-> Pretty (SyntaxText' r)
alignCase (Pretty (SyntaxText' r)
p, [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
gbs) =
          if Bool -> Bool
not ([(Pretty (SyntaxText' r), Pretty (SyntaxText' r))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int
-> [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
-> [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
forall a. Int -> [a] -> [a]
drop Int
1 [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
gbs))
            then Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang Pretty (SyntaxText' r)
p Pretty (SyntaxText' r)
guardBlock
            else Pretty (SyntaxText' r)
p Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
guardBlock
          where
            guardBlock :: Pretty (SyntaxText' r)
guardBlock =
              [Pretty (SyntaxText' r)] -> Pretty (SyntaxText' r)
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty (SyntaxText' r)] -> Pretty (SyntaxText' r))
-> [Pretty (SyntaxText' r)] -> Pretty (SyntaxText' r)
forall a b. (a -> b) -> a -> b
$
                ((Pretty (SyntaxText' r),
  (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))
 -> Pretty (SyntaxText' r))
-> [(Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
-> [Pretty (SyntaxText' r)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                  ( \(Pretty (SyntaxText' r)
g, (Pretty (SyntaxText' r)
a, Pretty (SyntaxText' r)
b)) ->
                      Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
                        ( Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall s. Pretty s -> Pretty s
PP.group
                            (Pretty (SyntaxText' r)
g Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> (if Bool
alignArrows then Pretty (SyntaxText' r)
"" else Pretty (SyntaxText' r)
" ") Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
a)
                        )
                        Pretty (SyntaxText' r)
b
                  )
                  [(Pretty (SyntaxText' r),
  (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
justified
            justified :: [(Pretty (SyntaxText' r),
  (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
justified = [(Pretty (SyntaxText' r),
  (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
-> [(Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
forall s a.
(Eq s, ListLike s Char, IsString s) =>
[(Pretty s, a)] -> [(Pretty s, a)]
PP.leftJustify ([(Pretty (SyntaxText' r),
   (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
 -> [(Pretty (SyntaxText' r),
      (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))])
-> [(Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
-> [(Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
forall a b. (a -> b) -> a -> b
$ ((Pretty (SyntaxText' r), Pretty (SyntaxText' r))
 -> (Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r))))
-> [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
-> [(Pretty (SyntaxText' r),
     (Pretty (SyntaxText' r), Pretty (SyntaxText' r)))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Pretty (SyntaxText' r)
g, Pretty (SyntaxText' r)
b) -> (Pretty (SyntaxText' r)
g, (Pretty (SyntaxText' r)
forall {r}. Pretty (SyntaxText' r)
arrow, Pretty (SyntaxText' r)
b))) [(Pretty (SyntaxText' r), Pretty (SyntaxText' r))]
gbs
    grid :: m [(Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])]
grid = (([Pattern ()], [v],
  [(Maybe (Term (F v () ()) v PrintAnnotation),
    ([v], Term (F v () ()) v PrintAnnotation))])
 -> m (Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText]))
-> [([Pattern ()], [v],
     [(Maybe (Term (F v () ()) v PrintAnnotation),
       ([v], Term (F v () ()) v PrintAnnotation))])]
-> m [(Pretty SyntaxText, [Pretty SyntaxText],
       [Pretty SyntaxText])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Pattern ()], [v],
 [(Maybe (Term (F v () ()) v PrintAnnotation),
   ([v], Term (F v () ()) v PrintAnnotation))])
-> m (Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])
go ([MatchCase' () (Term (F v () ()) v PrintAnnotation)]
-> [([Pattern ()], [v],
     [(Maybe (Term (F v () ()) v PrintAnnotation),
       ([v], Term (F v () ()) v PrintAnnotation))])]
forall v ann.
Ord v =>
[MatchCase' () (Term3 v ann)]
-> [([Pattern ()], [v],
     [(Maybe (Term3 v ann), ([v], Term3 v ann))])]
groupCases [MatchCase' () (Term (F v () ()) v PrintAnnotation)]
ms)
    patLhs :: PrettyPrintEnv -> [v] -> [Pattern ()] -> Pretty SyntaxText
    patLhs :: PrettyPrintEnv -> [v] -> [Pattern ()] -> Pretty SyntaxText
patLhs PrettyPrintEnv
ppe [v]
vs = \cases
      [Pattern ()
pat] -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group ((Pretty SyntaxText, [v]) -> Pretty SyntaxText
forall a b. (a, b) -> a
fst (PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern ()
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
ppe (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Precedence
Bottom [v]
vs Pattern ()
pat))
      [Pattern ()]
pats -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group
        (Pretty SyntaxText -> Pretty SyntaxText)
-> ((Pattern () -> StateT [v] Identity (Pretty SyntaxText))
    -> Pretty SyntaxText)
-> (Pattern () -> StateT [v] Identity (Pretty SyntaxText))
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep (Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.indentAfterNewline Pretty SyntaxText
"  " (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"," Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
forall s. IsString s => Pretty s
PP.softbreak)
        ([Pretty SyntaxText] -> Pretty SyntaxText)
-> ((Pattern () -> StateT [v] Identity (Pretty SyntaxText))
    -> [Pretty SyntaxText])
-> (Pattern () -> StateT [v] Identity (Pretty SyntaxText))
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [v] [Pretty SyntaxText] -> [v] -> [Pretty SyntaxText]
forall s a. State s a -> s -> a
`evalState` [v]
vs)
        (State [v] [Pretty SyntaxText] -> [Pretty SyntaxText])
-> ((Pattern () -> StateT [v] Identity (Pretty SyntaxText))
    -> State [v] [Pretty SyntaxText])
-> (Pattern () -> StateT [v] Identity (Pretty SyntaxText))
-> [Pretty SyntaxText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pattern ()]
-> (Pattern () -> StateT [v] Identity (Pretty SyntaxText))
-> State [v] [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Pattern ()]
pats
        ((Pattern () -> StateT [v] Identity (Pretty SyntaxText))
 -> Pretty SyntaxText)
-> (Pattern () -> StateT [v] Identity (Pretty SyntaxText))
-> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ \Pattern ()
pat -> do
          [v]
vs <- StateT [v] Identity [v]
forall s (m :: * -> *). MonadState s m => m s
State.get
          let (Pretty SyntaxText
p, [v]
rem) = PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern ()
-> (Pretty SyntaxText, [v])
forall v loc.
Var v =>
PrettyPrintEnv
-> AmbientContext
-> Precedence
-> [v]
-> Pattern loc
-> (Pretty SyntaxText, [v])
prettyPattern PrettyPrintEnv
ppe (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Precedence
Bottom [v]
vs Pattern ()
pat
          [v] -> StateT [v] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put [v]
rem
          pure Pretty SyntaxText
p
    arrow :: Pretty (SyntaxText' r)
arrow = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.ControlKeyword Pretty (SyntaxText' r)
"->"
    -- If there's multiple guarded cases for this pattern, prints as:
    -- MyPattern x y
    --   | guard 1        -> 1
    --   | otherguard x y -> 2
    --   | otherwise      -> 3
    go :: ([Pattern ()], [v],
 [(Maybe (Term (F v () ()) v PrintAnnotation),
   ([v], Term (F v () ()) v PrintAnnotation))])
-> m (Pretty SyntaxText, [Pretty SyntaxText], [Pretty SyntaxText])
go ([Pattern ()]
pats, [v]
vs, [(Maybe (Term (F v () ()) v PrintAnnotation),
  ([v], Term (F v () ()) v PrintAnnotation))]
-> ([Maybe (Term (F v () ()) v PrintAnnotation)],
    [([v], Term (F v () ()) v PrintAnnotation)])
forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Maybe (Term (F v () ()) v PrintAnnotation)]
guards, [([v], Term (F v () ()) v PrintAnnotation)]
bodies)) = do
      [Pretty SyntaxText]
guards' <- (Maybe (Term (F v () ()) v PrintAnnotation)
 -> m (Pretty SyntaxText))
-> [Maybe (Term (F v () ()) v PrintAnnotation)]
-> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Maybe (Term (F v () ()) v PrintAnnotation) -> m (Pretty SyntaxText)
printGuard [Maybe (Term (F v () ()) v PrintAnnotation)]
guards
      [Pretty SyntaxText]
bodies' <- (([v], Term (F v () ()) v PrintAnnotation)
 -> m (Pretty SyntaxText))
-> [([v], Term (F v () ()) v PrintAnnotation)]
-> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([v], Term (F v () ()) v PrintAnnotation) -> m (Pretty SyntaxText)
printBody [([v], Term (F v () ()) v PrintAnnotation)]
bodies
      Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
      pure (PrettyPrintEnv -> [v] -> [Pattern ()] -> Pretty SyntaxText
patLhs Env v
env.ppe [v]
vs [Pattern ()]
pats, [Pretty SyntaxText]
guards', [Pretty SyntaxText]
bodies')
      where
        noGuards :: Bool
noGuards = (Maybe (Term (F v () ()) v PrintAnnotation) -> Bool)
-> [Maybe (Term (F v () ()) v PrintAnnotation)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe (Term (F v () ()) v PrintAnnotation)
-> Maybe (Term (F v () ()) v PrintAnnotation) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing) [Maybe (Term (F v () ()) v PrintAnnotation)]
guards
        printGuard :: Maybe (Term (F v () ()) v PrintAnnotation) -> m (Pretty SyntaxText)
printGuard Maybe (Term (F v () ()) v PrintAnnotation)
Nothing | Bool
noGuards = Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pretty SyntaxText
forall a. Monoid a => a
mempty
        printGuard Maybe (Term (F v () ()) v PrintAnnotation)
Nothing =
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"|" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.ControlKeyword Pretty SyntaxText
"otherwise"
        printGuard (Just (ABT.AbsN' [v]
_ Term (F v () ()) v PrintAnnotation
g)) =
          -- strip off any Abs-chain around the guard, guard variables are rendered
          -- like any other variable, ex: case Foo x y | x < y -> ...
          Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. (Eq s, IsString s) => Pretty s -> Pretty s -> Pretty s
PP.spaceIfNeeded (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DelimiterChar Pretty SyntaxText
"|")
            (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbientContext
-> Term (F v () ()) v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Control BlockContext
Normal Imports
im DocLiteralContext
doc) Term (F v () ()) v PrintAnnotation
g
        printBody :: ([v], Term (F v () ()) v PrintAnnotation) -> m (Pretty SyntaxText)
printBody ([v]
vs, Term (F v () ()) v PrintAnnotation
body) = [v] -> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall v (m :: * -> *) a. MonadPretty v m => [v] -> m a -> m a
withBoundTerms [v]
vs (AmbientContext
-> Term (F v () ()) v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Annotation BlockContext
Block Imports
im DocLiteralContext
doc) Term (F v () ()) v PrintAnnotation
body)

-- A pretty term binding, split into the type signature (possibly empty) and the term.
data PrettyBinding = PrettyBinding
  { PrettyBinding -> Maybe (Pretty SyntaxText)
typeSignature :: Maybe (Pretty SyntaxText),
    PrettyBinding -> Pretty SyntaxText
term :: Pretty SyntaxText
  }

-- Render a pretty binding.
renderPrettyBinding :: PrettyBinding -> Pretty SyntaxText
renderPrettyBinding :: PrettyBinding -> Pretty SyntaxText
renderPrettyBinding PrettyBinding {Maybe (Pretty SyntaxText)
$sel:typeSignature:PrettyBinding :: PrettyBinding -> Maybe (Pretty SyntaxText)
typeSignature :: Maybe (Pretty SyntaxText)
typeSignature, Pretty SyntaxText
$sel:term:PrettyBinding :: PrettyBinding -> Pretty SyntaxText
term :: Pretty SyntaxText
term} =
  case Maybe (Pretty SyntaxText)
typeSignature of
    Maybe (Pretty SyntaxText)
Nothing -> Pretty SyntaxText
term
    Just Pretty SyntaxText
ty -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines [Pretty SyntaxText
ty, Pretty SyntaxText
term]

-- Render a pretty binding without a type signature.
renderPrettyBindingWithoutTypeSignature :: PrettyBinding -> Pretty SyntaxText
renderPrettyBindingWithoutTypeSignature :: PrettyBinding -> Pretty SyntaxText
renderPrettyBindingWithoutTypeSignature PrettyBinding {Pretty SyntaxText
$sel:term:PrettyBinding :: PrettyBinding -> Pretty SyntaxText
term :: Pretty SyntaxText
term} =
  Pretty SyntaxText
term

-- | Render a binding, producing output of the form
--
-- foo : t -> u
-- foo a = ...
--
-- The first line is only output if the term has a type annotation as the
-- outermost constructor.
--
-- Binary functions with symbolic names are output infix, as follows:
--
-- (+) : t -> t -> t
-- a + b = ...
prettyBinding ::
  (Var v) =>
  PrettyPrintEnv ->
  HQ.HashQualified Name ->
  Term2 v at ap v a ->
  Pretty SyntaxText
prettyBinding :: forall v at ap a.
Var v =>
PrettyPrintEnv
-> HashQualified Name -> Term2 v at ap v a -> Pretty SyntaxText
prettyBinding =
  (PrettyBinding -> Pretty SyntaxText)
-> PrettyPrintEnv
-> HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
forall v at ap a.
Var v =>
(PrettyBinding -> Pretty SyntaxText)
-> PrettyPrintEnv
-> HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding_ PrettyBinding -> Pretty SyntaxText
renderPrettyBinding

-- | Like 'prettyBinding', but elides the type signature (if any).
prettyBindingWithoutTypeSignature ::
  (Var v) =>
  PrettyPrintEnv ->
  HQ.HashQualified Name ->
  Term2 v at ap v a ->
  Pretty SyntaxText
prettyBindingWithoutTypeSignature :: forall v at ap a.
Var v =>
PrettyPrintEnv
-> HashQualified Name -> Term2 v at ap v a -> Pretty SyntaxText
prettyBindingWithoutTypeSignature =
  (PrettyBinding -> Pretty SyntaxText)
-> PrettyPrintEnv
-> HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
forall v at ap a.
Var v =>
(PrettyBinding -> Pretty SyntaxText)
-> PrettyPrintEnv
-> HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding_ PrettyBinding -> Pretty SyntaxText
renderPrettyBindingWithoutTypeSignature

prettyBinding_ ::
  (Var v) =>
  (PrettyBinding -> Pretty SyntaxText) ->
  PrettyPrintEnv ->
  HQ.HashQualified Name ->
  Term2 v at ap v a ->
  Pretty SyntaxText
prettyBinding_ :: forall v at ap a.
Var v =>
(PrettyBinding -> Pretty SyntaxText)
-> PrettyPrintEnv
-> HashQualified Name
-> Term2 v at ap v a
-> Pretty SyntaxText
prettyBinding_ PrettyBinding -> Pretty SyntaxText
go PrettyPrintEnv
ppe HashQualified Name
n Term2 v at ap v a
tm =
  PrettyPrintEnv
-> Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText
forall v a. Var v => PrettyPrintEnv -> Reader (Env v) a -> a
runPretty (Term2 v at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term2 v at ap v a
tm PrettyPrintEnv
ppe) (Reader (Env v) (Pretty SyntaxText) -> Pretty SyntaxText)
-> (ReaderT (Env v) Identity PrettyBinding
    -> Reader (Env v) (Pretty SyntaxText))
-> ReaderT (Env v) Identity PrettyBinding
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrettyBinding -> Pretty SyntaxText)
-> ReaderT (Env v) Identity PrettyBinding
-> Reader (Env v) (Pretty SyntaxText)
forall a b.
(a -> b)
-> ReaderT (Env v) Identity a -> ReaderT (Env v) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrettyBinding -> Pretty SyntaxText
go (ReaderT (Env v) Identity PrettyBinding -> Pretty SyntaxText)
-> ReaderT (Env v) Identity PrettyBinding -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ AmbientContext
-> HashQualified Name
-> Term2 v at ap v a
-> ReaderT (Env v) Identity PrettyBinding
forall v (m :: * -> *) at ap a.
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term2 v at ap v a -> m PrettyBinding
prettyBinding0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Basement BlockContext
Block Imports
forall k a. Map k a
Map.empty DocLiteralContext
MaybeDoc) HashQualified Name
n Term2 v at ap v a
tm

prettyBinding' ::
  (Var v) =>
  PrettyPrintEnv ->
  Width ->
  HQ.HashQualified Name ->
  Term v a ->
  ColorText
prettyBinding' :: forall v a.
Var v =>
PrettyPrintEnv
-> Width -> HashQualified Name -> Term v a -> ColorText
prettyBinding' PrettyPrintEnv
ppe Width
width HashQualified Name
v Term v a
t =
  Width -> Pretty ColorText -> ColorText
forall s. (Monoid s, IsString s) => Width -> Pretty s -> s
PP.render Width
width (Pretty ColorText -> ColorText)
-> (Pretty SyntaxText -> Pretty ColorText)
-> Pretty SyntaxText
-> ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor (Pretty SyntaxText -> ColorText) -> Pretty SyntaxText -> ColorText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv
-> HashQualified Name -> Term v a -> Pretty SyntaxText
forall v at ap a.
Var v =>
PrettyPrintEnv
-> HashQualified Name -> Term2 v at ap v a -> Pretty SyntaxText
prettyBinding PrettyPrintEnv
ppe HashQualified Name
v Term v a
t

prettyBinding0 ::
  (MonadPretty v m) =>
  AmbientContext ->
  HQ.HashQualified Name ->
  Term2 v at ap v a ->
  m PrettyBinding
prettyBinding0 :: forall v (m :: * -> *) at ap a.
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term2 v at ap v a -> m PrettyBinding
prettyBinding0 AmbientContext
ac HashQualified Name
v Term2 v at ap v a
tm = do
  Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
  (Env v -> Env v) -> m PrettyBinding -> m PrettyBinding
forall a. (Env v -> Env v) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter (Env v) (Env v) (Set v) (Set v) -> Set v -> Env v -> Env v
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Env v) (Env v) (Set v) (Set v)
#freeTerms (Term2 v at ap v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term2 v at ap v a
tm)) (AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
prettyBinding0' AmbientContext
ac HashQualified Name
v (PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate Env v
env.ppe Term2 v at ap v a
tm))

prettyBinding0' ::
  (MonadPretty v m) =>
  AmbientContext ->
  HQ.HashQualified Name ->
  Term3 v PrintAnnotation ->
  m PrettyBinding
prettyBinding0' :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
prettyBinding0' a :: AmbientContext
a@AmbientContext {$sel:imports:AmbientContext :: AmbientContext -> Imports
imports = Imports
im, $sel:docContext:AmbientContext :: AmbientContext -> DocLiteralContext
docContext = DocLiteralContext
doc} HashQualified Name
v Term2 v () () v PrintAnnotation
term =
  Bool -> Term2 v () () v PrintAnnotation -> m PrettyBinding
go (Bool
symbolic Bool -> Bool -> Bool
&& Term2 v () () v PrintAnnotation -> Bool
forall {typeVar} {typeAnn} {patternAnn} {a}.
Term (F typeVar typeAnn patternAnn) v a -> Bool
isBinary Term2 v () () v PrintAnnotation
term) Term2 v () () v PrintAnnotation
term
  where
    go :: Bool -> Term2 v () () v PrintAnnotation -> m PrettyBinding
go Bool
infix' Term2 v () () v PrintAnnotation
binding =
      case Term2 v () () v PrintAnnotation
binding of
        Ann' Term2 v () () v PrintAnnotation
tm Type v ()
tp -> do
          -- If the term is an annotated function,
          -- we want to print the type signature on the previous line.
          -- The TypePrinter.pretty0 function prints the type, and uses a
          -- Reader monad with (Set v) in it to track which type variables are
          -- bound in the outer scope. We use that to determine if the type
          -- printer should avoid capture of those variables.
          let avoidCapture :: m PrettyBinding -> m PrettyBinding
avoidCapture = case Type v ()
tp of
                ForallsNamed' [v]
vs Type v ()
_ -> [v] -> m PrettyBinding -> m PrettyBinding
forall v (m :: * -> *) a. MonadPretty v m => [v] -> m a -> m a
addTypeVars [v]
vs
                Type v ()
_ -> m PrettyBinding -> m PrettyBinding
forall a. a -> a
id
          Pretty SyntaxText
tp' <- Imports -> Int -> Type v () -> m (Pretty SyntaxText)
forall v a (m :: * -> *).
MonadPretty v m =>
Imports -> Int -> Type v a -> m (Pretty SyntaxText)
TypePrinter.pretty0 Imports
im (-Int
1) Type v ()
tp
          PrettyBinding
tm' <- m PrettyBinding -> m PrettyBinding
avoidCapture (AmbientContext
-> HashQualified Name
-> Term2 v () () v PrintAnnotation
-> m PrettyBinding
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> HashQualified Name -> Term3 v PrintAnnotation -> m PrettyBinding
prettyBinding0' AmbientContext
a HashQualified Name
v Term2 v () () v PrintAnnotation
tm)
          pure
            PrettyBinding
              { $sel:typeSignature:PrettyBinding :: Maybe (Pretty SyntaxText)
typeSignature = Pretty SyntaxText -> Maybe (Pretty SyntaxText)
forall a. a -> Maybe a
Just (Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (HashQualified Name -> Pretty SyntaxText
renderName HashQualified Name
v Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.TypeAscriptionColon Pretty SyntaxText
" :") Pretty SyntaxText
tp')),
                $sel:term:PrettyBinding :: Pretty SyntaxText
term = Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (PrettyBinding -> Pretty SyntaxText
renderPrettyBinding PrettyBinding
tm')
              }
        LamsNamedMatch' [v]
vs [([Pattern ()], Maybe (Term2 v () () v PrintAnnotation),
  Term2 v () () v PrintAnnotation)]
branches -> do
          Pretty SyntaxText
branches' <- Imports
-> DocLiteralContext
-> [([Pattern ()], Maybe (Term2 v () () v PrintAnnotation),
     Term2 v () () v PrintAnnotation)]
-> m (Pretty SyntaxText)
forall (m :: * -> *) v.
MonadPretty v m =>
Imports
-> DocLiteralContext
-> [MatchCase' () (Term3 v PrintAnnotation)]
-> m (Pretty SyntaxText)
printCase Imports
im DocLiteralContext
doc [([Pattern ()], Maybe (Term2 v () () v PrintAnnotation),
  Term2 v () () v PrintAnnotation)]
branches
          pure
            PrettyBinding
              { $sel:typeSignature:PrettyBinding :: Maybe (Pretty SyntaxText)
typeSignature = Maybe (Pretty SyntaxText)
forall a. Maybe a
Nothing,
                $sel:term:PrettyBinding :: Pretty SyntaxText
term =
                  Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
                    Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group
                      ( HashQualified Name -> [v] -> Pretty SyntaxText
defnLhs HashQualified Name
v [v]
vs
                          Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BindingEquals Pretty SyntaxText
" ="
                          Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" "
                          Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt
                            Element Reference
forall r. Element r
S.ControlKeyword
                            Pretty SyntaxText
"cases"
                      )
                      Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` Pretty SyntaxText
branches'
              }
        LamsNamedOrDelay' [v]
vs Term2 v () () v PrintAnnotation
body -> do
          Pretty SyntaxText
prettyBody <- AmbientContext
-> Term2 v () () v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 (Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac (AmbientContext -> Precedence
precedence AmbientContext
a) BlockContext
Block Imports
im DocLiteralContext
doc) Term2 v () () v PrintAnnotation
body
          case Term2 v () () v PrintAnnotation
body of
            -- allow soft hangs when first line is a function application
            -- that ends in a delay or other soft-hangable element
            --   foo = fork loc do
            --     ...
            --   foo =
            --     fork loc do
            --       ...
            Apps' Term2 v () () v PrintAnnotation
_f [Term2 v () () v PrintAnnotation]
args
              | Just ([Term2 v () () v PrintAnnotation]
_, Term2 v () () v PrintAnnotation
last) <- [Term2 v () () v PrintAnnotation]
-> Maybe
     ([Term2 v () () v PrintAnnotation],
      Term2 v () () v PrintAnnotation)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc [Term2 v () () v PrintAnnotation]
args,
                Term2 v () () v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term2 v () () v PrintAnnotation
last ->
                  PrettyBinding -> m PrettyBinding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrettyBinding -> m PrettyBinding)
-> PrettyBinding -> m PrettyBinding
forall a b. (a -> b) -> a -> b
$
                    PrettyBinding
                      { $sel:typeSignature:PrettyBinding :: Maybe (Pretty SyntaxText)
typeSignature = Maybe (Pretty SyntaxText)
forall a. Maybe a
Nothing,
                        $sel:term:PrettyBinding :: Pretty SyntaxText
term =
                          Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
                            Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (HashQualified Name -> [v] -> Pretty SyntaxText
defnLhs HashQualified Name
v [v]
vs Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BindingEquals Pretty SyntaxText
" = ")
                              Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyBody
                                Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
`PP.orElse` (Pretty SyntaxText
"\n" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Width -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
PP.indentN Width
2 Pretty SyntaxText
prettyBody)
                      }
            Term2 v () () v PrintAnnotation
_ ->
              PrettyBinding -> m PrettyBinding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrettyBinding -> m PrettyBinding)
-> PrettyBinding -> m PrettyBinding
forall a b. (a -> b) -> a -> b
$
                -- Special case for 'let being on the same line
                let hang :: Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
hang = if Term2 v () () v PrintAnnotation -> Bool
forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable Term2 v () () v PrintAnnotation
body then Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.softHang else Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.hang
                 in PrettyBinding
                      { $sel:typeSignature:PrettyBinding :: Maybe (Pretty SyntaxText)
typeSignature = Maybe (Pretty SyntaxText)
forall a. Maybe a
Nothing,
                        $sel:term:PrettyBinding :: Pretty SyntaxText
term =
                          Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
                            Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (HashQualified Name -> [v] -> Pretty SyntaxText
defnLhs HashQualified Name
v [v]
vs Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.BindingEquals Pretty SyntaxText
" =") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
`hang` Pretty SyntaxText
prettyBody
                      }
        Term2 v () () v PrintAnnotation
t -> String -> m PrettyBinding
forall a. HasCallStack => String -> a
error (String
"prettyBinding0: unexpected term: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term2 v () () v PrintAnnotation -> String
forall a. Show a => a -> String
show Term2 v () () v PrintAnnotation
t)
      where
        defnLhs :: HashQualified Name -> [v] -> Pretty SyntaxText
defnLhs HashQualified Name
v [v]
vs
          | Bool
infix' = case [v]
vs of
              v
x : v
y : [v]
_ ->
                Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep
                  Pretty SyntaxText
" "
                  [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (v -> Text
forall v. Var v => v -> Text
Var.name v
x),
                    (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Element Reference
forall r. HashQualified Name -> Element r
S.HashQualifier HashQualified Name
v) (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im HashQualified Name
v,
                    Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (v -> Text
forall v. Var v => v -> Text
Var.name v
y)
                  ]
              [v
x] ->
                Pretty SyntaxText -> [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
PP.sep
                  Pretty SyntaxText
" "
                  [ HashQualified Name -> Pretty SyntaxText
renderName HashQualified Name
v,
                    Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Var (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (v -> Text
forall v. Var v => v -> Text
Var.name v
x)
                  ]
              [v]
_ -> String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"error"
          | [v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
vs = HashQualified Name -> Pretty SyntaxText
renderName HashQualified Name
v
          | Bool
otherwise = HashQualified Name -> Pretty SyntaxText
renderName HashQualified Name
v Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
`PP.hang` [v] -> Pretty SyntaxText
forall {r}. [v] -> Pretty (SyntaxText' r)
args [v]
vs
        args :: [v] -> Pretty (SyntaxText' r)
args = (v -> Pretty (SyntaxText' r)) -> [v] -> Pretty (SyntaxText' r)
forall (f :: * -> *) s a.
(Foldable f, IsString s) =>
(a -> Pretty s) -> f a -> Pretty s
PP.spacedMap ((v -> Pretty (SyntaxText' r)) -> [v] -> Pretty (SyntaxText' r))
-> (v -> Pretty (SyntaxText' r)) -> [v] -> Pretty (SyntaxText' r)
forall a b. (a -> b) -> a -> b
$ Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.Var (Pretty (SyntaxText' r) -> Pretty (SyntaxText' r))
-> (v -> Pretty (SyntaxText' r)) -> v -> Pretty (SyntaxText' r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pretty (SyntaxText' r)
forall s. IsString s => Text -> Pretty s
PP.text (Text -> Pretty (SyntaxText' r))
-> (v -> Text) -> v -> Pretty (SyntaxText' r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name
        renderName :: HashQualified Name -> Pretty SyntaxText
renderName HashQualified Name
n =
          let n' :: HashQualified Name
n' = Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im HashQualified Name
n
           in HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
n' InfixContext
NonInfix (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Element Reference
forall r. HashQualified Name -> Element r
S.HashQualifier HashQualified Name
n') HashQualified Name
n'
    symbolic :: Bool
symbolic = HashQualified Name -> Bool
isSymbolic HashQualified Name
v
    isBinary :: Term (F typeVar typeAnn patternAnn) v a -> Bool
isBinary = \case
      Ann' Term (F typeVar typeAnn patternAnn) v a
tm Type typeVar typeAnn
_ -> Term (F typeVar typeAnn patternAnn) v a -> Bool
isBinary Term (F typeVar typeAnn patternAnn) v a
tm
      LamsNamedMatch' [v]
vs [([Pattern patternAnn],
  Maybe (Term (F typeVar typeAnn patternAnn) v a),
  Term (F typeVar typeAnn patternAnn) v a)]
_ -> [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      LamsNamedOrDelay' [v]
vs Term (F typeVar typeAnn patternAnn) v a
_ -> [v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
      Term (F typeVar typeAnn patternAnn) v a
_ -> Bool
False -- unhittable

isDocLiteral :: Term3 v PrintAnnotation -> Bool
isDocLiteral :: forall v. Term3 v PrintAnnotation -> Bool
isDocLiteral Term3 v PrintAnnotation
term = case Term3 v PrintAnnotation
term of
  DD.DocJoin Seq (Term3 v PrintAnnotation)
segs -> (Term3 v PrintAnnotation -> Bool)
-> Seq (Term3 v PrintAnnotation) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Term3 v PrintAnnotation -> Bool
forall v. Term3 v PrintAnnotation -> Bool
isDocLiteral Seq (Term3 v PrintAnnotation)
segs
  DD.DocBlob Text
_ -> Bool
True
  DD.DocLink (DD.LinkTerm (TermLink' Referent
_)) -> Bool
True
  DD.DocLink (DD.LinkType (TypeLink' Reference
_)) -> Bool
True
  DD.DocSource (DD.LinkTerm (TermLink' Referent
_)) -> Bool
True
  DD.DocSource (DD.LinkType (TypeLink' Reference
_)) -> Bool
True
  DD.DocSignature (TermLink' Referent
_) -> Bool
True
  DD.DocEvaluate (TermLink' Referent
_) -> Bool
True
  Ref' Reference
_ -> Bool
True -- @[include]
  Term3 v PrintAnnotation
_ -> Bool
False

-- Similar to DisplayValues.displayDoc, but does not follow and expand references.
prettyDoc :: (Var v) => PrettyPrintEnv -> Imports -> Term3 v a -> Pretty SyntaxText
prettyDoc :: forall v a.
Var v =>
PrettyPrintEnv -> Imports -> Term3 v a -> Pretty SyntaxText
prettyDoc PrettyPrintEnv
n Imports
im Term3 v a
term =
  [Pretty SyntaxText] -> Pretty SyntaxText
forall m. Monoid m => [m] -> m
mconcat
    [ Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DocDelimiter (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"[: ",
      Term3 v a -> Pretty SyntaxText
go Term3 v a
term,
      Pretty SyntaxText
spaceUnlessBroken,
      Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DocDelimiter (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
":]"
    ]
  where
    go :: Term3 v a -> Pretty SyntaxText
go (DD.DocJoin Seq (Term3 v a)
segs) = (Term3 v a -> Pretty SyntaxText)
-> Seq (Term3 v a) -> Pretty SyntaxText
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Term3 v a -> Pretty SyntaxText
go Seq (Term3 v a)
segs
    go (DD.DocBlob Text
txt) = Text -> Pretty SyntaxText
forall s. (ListLike s Char, IsString s) => Text -> Pretty s
PP.paragraphyText (Text -> Text
escaped Text
txt)
    go (DD.DocLink (DD.LinkTerm (TermLink' Referent
r))) =
      Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DocDelimiter (String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"@") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
r) (Referent -> Pretty SyntaxText
fmtTerm Referent
r)
    go (DD.DocLink (DD.LinkType (TypeLink' Reference
r))) =
      Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.DocDelimiter (String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l String
"@") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Reference -> Element Reference
forall r. r -> Element r
S.TypeReference Reference
r) (Reference -> Pretty SyntaxText
fmtType Reference
r)
    go (DD.DocSource (DD.LinkTerm (TermLink' Referent
r))) =
      String -> Pretty SyntaxText
forall {r}. String -> Pretty (SyntaxText' r)
atKeyword String
"source" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
fmtTerm Referent
r
    go (DD.DocSource (DD.LinkType (TypeLink' Reference
r))) =
      String -> Pretty SyntaxText
forall {r}. String -> Pretty (SyntaxText' r)
atKeyword String
"source" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Reference -> Pretty SyntaxText
fmtType Reference
r
    go (DD.DocSignature (TermLink' Referent
r)) =
      String -> Pretty SyntaxText
forall {r}. String -> Pretty (SyntaxText' r)
atKeyword String
"signature" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
fmtTerm Referent
r
    go (DD.DocEvaluate (TermLink' Referent
r)) =
      String -> Pretty SyntaxText
forall {r}. String -> Pretty (SyntaxText' r)
atKeyword String
"evaluate" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
fmtTerm Referent
r
    go (Ref' Reference
r) = String -> Pretty SyntaxText
forall {r}. String -> Pretty (SyntaxText' r)
atKeyword String
"include" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
fmtTerm (Reference -> Referent
Referent.Ref Reference
r)
    go Term3 v a
_ = String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
l (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ String
"(invalid doc literal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Term3 v a -> String
forall a. Show a => a -> String
show Term3 v a
term String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    fmtName :: HashQualified Name -> Pretty SyntaxText
fmtName HashQualified Name
s = (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Element Reference
forall r. HashQualified Name -> Element r
S.HashQualifier HashQualified Name
s) (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im HashQualified Name
s
    fmtTerm :: Referent -> Pretty SyntaxText
fmtTerm Referent
r = HashQualified Name -> Pretty SyntaxText
fmtName (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n Referent
r
    fmtType :: Reference -> Pretty SyntaxText
fmtType Reference
r = HashQualified Name -> Pretty SyntaxText
fmtName (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Reference -> HashQualified Name
PrettyPrintEnv.typeName PrettyPrintEnv
n Reference
r
    atKeyword :: String -> Pretty (SyntaxText' r)
atKeyword String
w =
      Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
"@[")
        Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocKeyword (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
w)
        Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
"] ")
    escaped :: Text -> Text
escaped = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"@" Text
"\\@" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
":]" Text
"\\:]"
    spaceUnlessBroken :: Pretty SyntaxText
spaceUnlessBroken = Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s -> Pretty s
PP.orElse Pretty SyntaxText
" " Pretty SyntaxText
""

paren :: Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren :: Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren Bool
b Pretty SyntaxText
s = Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup Bool
b Pretty SyntaxText
s

parenNoGroup :: Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup :: Bool -> Pretty SyntaxText -> Pretty SyntaxText
parenNoGroup Bool
True Pretty SyntaxText
s = Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Parenthesis Pretty SyntaxText
"(" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
s Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element Reference
forall r. Element r
S.Parenthesis Pretty SyntaxText
")"
parenNoGroup Bool
False Pretty SyntaxText
s = Pretty SyntaxText
s

parenIfInfix ::
  HQ.HashQualified Name ->
  InfixContext ->
  (Pretty SyntaxText -> Pretty SyntaxText)
parenIfInfix :: HashQualified Name
-> InfixContext -> Pretty SyntaxText -> Pretty SyntaxText
parenIfInfix HashQualified Name
name InfixContext
ic =
  if HashQualified Name -> Bool
isSymbolic HashQualified Name
name Bool -> Bool -> Bool
&& InfixContext
ic InfixContext -> InfixContext -> Bool
forall a. Eq a => a -> a -> Bool
== InfixContext
NonInfix then Bool -> Pretty SyntaxText -> Pretty SyntaxText
paren Bool
True else Pretty SyntaxText -> Pretty SyntaxText
forall a. a -> a
id

l :: (IsString s) => String -> Pretty s
l :: forall s. IsString s => String -> Pretty s
l = String -> Pretty s
forall s. IsString s => String -> s
fromString

isSymbolic :: HQ.HashQualified Name -> Bool
isSymbolic :: HashQualified Name -> Bool
isSymbolic =
  Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Name -> Bool
Name.isSymboly (Maybe Name -> Bool)
-> (HashQualified Name -> Maybe Name) -> HashQualified Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName

emptyAc :: AmbientContext
emptyAc :: AmbientContext
emptyAc = Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Bottom BlockContext
Normal Imports
forall k a. Map k a
Map.empty DocLiteralContext
MaybeDoc

emptyBlockAc :: AmbientContext
emptyBlockAc :: AmbientContext
emptyBlockAc = Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
Bottom BlockContext
Block Imports
forall k a. Map k a
Map.empty DocLiteralContext
MaybeDoc

ac :: Precedence -> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac :: Precedence
-> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
ac Precedence
prec BlockContext
bc Imports
im DocLiteralContext
doc = Precedence
-> BlockContext
-> InfixContext
-> Imports
-> DocLiteralContext
-> Bool
-> AmbientContext
AmbientContext Precedence
prec BlockContext
bc InfixContext
NonInfix Imports
im DocLiteralContext
doc Bool
False

fmt :: S.Element r -> Pretty (S.SyntaxText' r) -> Pretty (S.SyntaxText' r)
fmt :: forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt = Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
PP.withSyntax

{-
   # FQN elision

   The term pretty-printer inserts `use` statements in some circumstances, to
   avoid the need for using fully-qualified names (FQNs) everywhere.  The
   following is an explanation and specification, as developed in issue #285.

   As an example, instead of

     foo p q r =
       if p then Util.bar q else Util.bar r

   we actually output the following.

     foo p q r =
       use Util bar
       if p then bar q else bar r

   Here, the `use` statement `use Util bar` has been inserted at the start of
   the block statement containing the `if`.  Within that scope, `Util.bar` can
   be referred to just with `bar`.  We say `Util` is the prefix, and `bar` is
   the suffix.

   When choosing where to place `use` statements, the pretty-printer tries to
   - float them down, deeper into the syntax tree, to keep them visually close
     to the use sites ('usages') of the names involved, but also tries to
   - minimize the number of repetitions of `use` statements for the same names
     by floating them up, towards the top of the syntax tree, so that one
     `use` statement takes effect over more name usages.

   It avoids producing output like the following.

     foo p q r =
       use My bar
       if p then bar q else Your.bar r

   Here `My.bar` is imported with a `use` statement, but `Your.bar` is not.
   We avoid this because it would be easy to misread `bar` as meaning
   `Your.bar`.  Instead both names are output fully qualified.

   This means that a `use` statement is only emitted for a name
   when the suffix is unique, across all the names referenced in the scope of
   the `use` statement.

   We don't emit a `use` statement for a name if it only occurs once within
   the scope (unless it's an infix operator, since they look nicer without
   a namespace qualifier.)

   The emitted code does not depend on Type-Driven Name Resolution (TDNR).
   For example, we emit
     foo =
       use Nat +
       1 + 2
   even though TDNR means that `foo = 1 + 2` would have had the same
   meaning.  That avoids the reader having to run typechecker logic in their
   head in order to know what functions are being called.

   Multi-level name qualification is allowed - like `Foo.Bar.baz`.  The
   pretty-printer tries to strip off as many sections of the prefix as
   possible, without causing a clash with other names.  If more sections
   can be stripped off, further down the tree, then it does this too.

   ## Specification

   We output a `use` statement for prefix P and suffix S at a given scope if
     - the scope is a block statement (so the `use` is syntactically valid)
     - the number of usages of the thing referred to by P.S within the scope
       - is > 1, or
       - is 1, and S is an infix operator
     - [uniqueness] there is no other Q with Q.S used in that scope
     - there is no longer prefix PP (and suffix s, with PP.s == P.S) which
       satisfies uniqueness
     - [narrowness] there is no block statement further down inside this one
       which contains all of the usages.

   Use statements in a block statement are sorted alphabetically by prefix.
   Suffixes covered by a single use statement are sorted alphabetically.
   Note that each `use` line cannot be line-broken.  Ideally they would
   fit the available space by splitting into multiple separate `use` lines.

   ## Algorithm

   Bubbling up from the leaves of the syntax tree, we calculate for each
   node, a `Map Suffix (Map Prefix Int)` (the 'usages map'), where the `Int`
   is the number of usages of Prefix.Suffix at/under that node.  (Note that
   a usage of `A.B.c` corresponds to two entries in the outer map.)  See
   `printAnnotate`.

   Once we have this decoration on all the terms, we start pretty-printing.
   As we recurse back down through the tree, we keep a `Map Name Suffix` (the
   'imports map'), to record the effect of all the `use` statements we've added
   in the nodes above.  When outputting names, we check this map to work out
   how to render them, using any suffix we find, or else falling back to the
   FQN.  At each block statement, each suffix in that term's usages map is a
   candidate to be imported with a use statement, subject to the various
   rules in the specification.

   # Debugging

   Start by enabling the tracing in elideFQN in PrettyPrintEnv.hs.

   There's also tracing in allInSubBlock to help when the narrowness check
   is playing up.

   # Semantics of imports

   Here is some background on how imports work.

   `use XYZ blah` brings `XYZ.blah` into scope, bound to the name `blah`. More
   generally, `use` is followed by a FQN prefix, then the local suffix.
   Concatenate the FQN prefix with the local suffix, with a dot between them,
   and you get the FQN, which is bound to the name equal to the local suffix.

   `use XYZ blah qux` is equivalent to the two statements (and this
   generalizes for any N symbols):
     use XYZ blah
     use XYZ qux

   This syntax works the same even if XYZ or blah have dots in them, so:
   `use Util.External My.Foo` brings `Util.External.My.Foo` into scope, bound
   to the name `My.Foo`.

   That's it. No wildcard imports, imports that do renaming, etc. We can
   consider adding some features like this later.
-}

newtype PrintAnnotation = PrintAnnotation
  { -- For each suffix that appears in/under this term, the set of prefixes
    -- used with that suffix, and how many times each occurs.
    PrintAnnotation -> Map Text (Map Prefix Int)
usages :: Map Suffix (Map Prefix Int)
  }
  deriving (Int -> PrintAnnotation -> ShowS
[PrintAnnotation] -> ShowS
PrintAnnotation -> String
(Int -> PrintAnnotation -> ShowS)
-> (PrintAnnotation -> String)
-> ([PrintAnnotation] -> ShowS)
-> Show PrintAnnotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrintAnnotation -> ShowS
showsPrec :: Int -> PrintAnnotation -> ShowS
$cshow :: PrintAnnotation -> String
show :: PrintAnnotation -> String
$cshowList :: [PrintAnnotation] -> ShowS
showList :: [PrintAnnotation] -> ShowS
Show)

instance Semigroup PrintAnnotation where
  PrintAnnotation {$sel:usages:PrintAnnotation :: PrintAnnotation -> Map Text (Map Prefix Int)
usages = Map Text (Map Prefix Int)
a} <> :: PrintAnnotation -> PrintAnnotation -> PrintAnnotation
<> PrintAnnotation {$sel:usages:PrintAnnotation :: PrintAnnotation -> Map Text (Map Prefix Int)
usages = Map Text (Map Prefix Int)
b} =
    PrintAnnotation {$sel:usages:PrintAnnotation :: Map Text (Map Prefix Int)
usages = (Map Prefix Int -> Map Prefix Int -> Map Prefix Int)
-> Map Text (Map Prefix Int)
-> Map Text (Map Prefix Int)
-> Map Text (Map Prefix Int)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map Prefix Int -> Map Prefix Int -> Map Prefix Int
forall {k} {a}. (Ord k, Num a) => Map k a -> Map k a -> Map k a
f Map Text (Map Prefix Int)
a Map Text (Map Prefix Int)
b}
    where
      f :: Map k a -> Map k a -> Map k a
f Map k a
a' Map k a
b' = (a -> a -> a) -> Map k a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith a -> a -> a
forall a. Num a => a -> a -> a
(+) Map k a
a' Map k a
b'

instance Monoid PrintAnnotation where
  mempty :: PrintAnnotation
mempty = PrintAnnotation {$sel:usages:PrintAnnotation :: Map Text (Map Prefix Int)
usages = Map Text (Map Prefix Int)
forall k a. Map k a
Map.empty}

suffixCounterTerm :: (Var v) => PrettyPrintEnv -> Set Name -> Set Name -> Term2 v at ap v a -> PrintAnnotation
suffixCounterTerm :: forall v at ap a.
Var v =>
PrettyPrintEnv
-> Set Name -> Set Name -> Term2 v at ap v a -> PrintAnnotation
suffixCounterTerm PrettyPrintEnv
n Set Name
usedTm Set Name
usedTy = \case
  Ref' Reference
r -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
usedTm (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n (Reference -> Referent
Referent.Ref Reference
r)
  Constructor' ConstructorReference
r | Reference -> Bool
noImportRefs (ConstructorReference
r ConstructorReference
-> Getting Reference ConstructorReference Reference -> Reference
forall s a. s -> Getting a s a -> a
^. Getting Reference ConstructorReference Reference
forall r s (f :: * -> *).
Functor f =>
(r -> f s)
-> GConstructorReference r -> f (GConstructorReference s)
ConstructorReference.reference_) -> PrintAnnotation
forall a. Monoid a => a
mempty
  Constructor' ConstructorReference
r -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
usedTm (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
r ConstructorType
CT.Data)
  Request' ConstructorReference
r -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
usedTm (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
n (ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
r ConstructorType
CT.Effect)
  Ann' Term2 v at ap v a
_ Type v at
t -> PrettyPrintEnv -> Set Name -> Type v at -> PrintAnnotation
forall v a.
(Var v, Ord v) =>
PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
countTypeUsages PrettyPrintEnv
n Set Name
usedTy Type v at
t
  Match' Term2 v at ap v a
_ [MatchCase ap (Term2 v at ap v a)]
bs ->
    let pat :: MatchCase loc a -> Pattern loc
pat (MatchCase Pattern loc
p Maybe a
_ a
_) = Pattern loc
p
     in (MatchCase ap (Term2 v at ap v a) -> PrintAnnotation)
-> [MatchCase ap (Term2 v at ap v a)] -> PrintAnnotation
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PrettyPrintEnv -> Set Name -> Pattern ap -> PrintAnnotation
forall loc.
PrettyPrintEnv -> Set Name -> Pattern loc -> PrintAnnotation
countPatternUsages PrettyPrintEnv
n Set Name
usedTm (Pattern ap -> PrintAnnotation)
-> (MatchCase ap (Term2 v at ap v a) -> Pattern ap)
-> MatchCase ap (Term2 v at ap v a)
-> PrintAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchCase ap (Term2 v at ap v a) -> Pattern ap
forall {loc} {a}. MatchCase loc a -> Pattern loc
pat) [MatchCase ap (Term2 v at ap v a)]
bs
  Term2 v at ap v a
_ -> PrintAnnotation
forall a. Monoid a => a
mempty

suffixCounterType :: (Var v) => PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
suffixCounterType :: forall v a.
Var v =>
PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
suffixCounterType PrettyPrintEnv
n Set Name
used = \case
  Type.Var' v
v -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
used (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ v -> HashQualified Name
forall v. Var v => v -> HashQualified Name
HQ.unsafeFromVar v
v
  Type.Ref' Reference
r | Reference -> Bool
noImportRefs Reference
r Bool -> Bool -> Bool
|| Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Type.listRef -> PrintAnnotation
forall a. Monoid a => a
mempty
  Type.Ref' Reference
r -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
used (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Reference -> HashQualified Name
PrettyPrintEnv.typeName PrettyPrintEnv
n Reference
r
  Type v a
_ -> PrintAnnotation
forall a. Monoid a => a
mempty

printAnnotate :: (Var v, Ord v) => PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate :: forall v at ap a.
(Var v, Ord v) =>
PrettyPrintEnv -> Term2 v at ap v a -> Term3 v PrintAnnotation
printAnnotate PrettyPrintEnv
n Term2 v at ap v a
tm =
  ((a, PrintAnnotation) -> PrintAnnotation)
-> Term (F v () ()) v (a, PrintAnnotation)
-> Term (F v () ()) v PrintAnnotation
forall a b.
(a -> b) -> Term (F v () ()) v a -> Term (F v () ()) v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, PrintAnnotation) -> PrintAnnotation
forall a b. (a, b) -> b
snd (Term2 v at ap v (a, PrintAnnotation)
-> Term (F v () ()) v (a, PrintAnnotation)
forall v at ap b. Ord v => Term2 v at ap v b -> Term2 v () () v b
go ((Term2 v at ap v a -> PrintAnnotation)
-> Term2 v at ap v a -> Term2 v at ap v (a, PrintAnnotation)
forall v (f :: * -> *) b a.
(Ord v, Foldable f, Functor f, Monoid b) =>
(Term f v a -> b) -> Term f v a -> Term f v (a, b)
reannotateUp (PrettyPrintEnv
-> Set Name -> Set Name -> Term2 v at ap v a -> PrintAnnotation
forall v at ap a.
Var v =>
PrettyPrintEnv
-> Set Name -> Set Name -> Term2 v at ap v a -> PrintAnnotation
suffixCounterTerm PrettyPrintEnv
n Set Name
usedTermNames Set Name
usedTypeNames) Term2 v at ap v a
tm))
  where
    -- See `countHQ` to see how these are used to make sure that
    -- a `use` clause doesn't introduce shadowing of a local variable
    usedTermNames :: Set Name
usedTermNames =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | v
v <- Term2 v at ap v a -> [v]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Term2 v at ap v a
tm, Name
n <- v -> [Name]
varToName v
v]
    usedTypeNames :: Set Name
usedTypeNames =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | Ann' Term2 v at ap v a
_ Type v at
ty <- Term2 v at ap v a -> [Term2 v at ap v a]
forall v (f :: * -> *) a.
(Ord v, Traversable f) =>
Term f v a -> [Term f v a]
ABT.subterms Term2 v at ap v a
tm, v
v <- Type v at -> [v]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Type v at
ty, Name
n <- v -> [Name]
varToName v
v]
    varToName :: v -> [Name]
varToName = Maybe Name -> [Name]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Name -> [Name]) -> (v -> Maybe Name) -> v -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Name
Name.parseText (Text -> Maybe Name) -> (v -> Text) -> v -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name (v -> Text) -> (v -> v) -> v -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> v
forall v. Var v => v -> v
Var.reset
    go :: (Ord v) => Term2 v at ap v b -> Term2 v () () v b
    go :: forall v at ap b. Ord v => Term2 v at ap v b -> Term2 v () () v b
go = (v -> v)
-> (at -> ())
-> (ap -> ())
-> Term2 v at ap v b
-> Term2 v () () v b
forall vt vt' at at' ap ap' v a.
(Ord vt, Ord vt') =>
(vt -> vt')
-> (at -> at')
-> (ap -> ap')
-> Term2 vt at ap v a
-> Term2 vt' at' ap' v a
extraMap' v -> v
forall a. a -> a
id (() -> at -> ()
forall a b. a -> b -> a
const ()) (() -> ap -> ()
forall a b. a -> b -> a
const ())

countTypeUsages :: (Var v, Ord v) => PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
countTypeUsages :: forall v a.
(Var v, Ord v) =>
PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
countTypeUsages PrettyPrintEnv
n Set Name
usedTy Type v a
t = (a, PrintAnnotation) -> PrintAnnotation
forall a b. (a, b) -> b
snd ((a, PrintAnnotation) -> PrintAnnotation)
-> (a, PrintAnnotation) -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ Term F v (a, PrintAnnotation) -> (a, PrintAnnotation)
forall (f :: * -> *) v a. Term f v a -> a
annotation (Term F v (a, PrintAnnotation) -> (a, PrintAnnotation))
-> Term F v (a, PrintAnnotation) -> (a, PrintAnnotation)
forall a b. (a -> b) -> a -> b
$ (Type v a -> PrintAnnotation)
-> Type v a -> Term F v (a, PrintAnnotation)
forall v (f :: * -> *) b a.
(Ord v, Foldable f, Functor f, Monoid b) =>
(Term f v a -> b) -> Term f v a -> Term f v (a, b)
reannotateUp (PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
forall v a.
Var v =>
PrettyPrintEnv -> Set Name -> Type v a -> PrintAnnotation
suffixCounterType PrettyPrintEnv
n Set Name
usedTy) Type v a
t

countPatternUsages :: PrettyPrintEnv -> Set Name -> Pattern loc -> PrintAnnotation
countPatternUsages :: forall loc.
PrettyPrintEnv -> Set Name -> Pattern loc -> PrintAnnotation
countPatternUsages PrettyPrintEnv
n Set Name
usedTm = (Pattern loc -> PrintAnnotation) -> Pattern loc -> PrintAnnotation
forall m loc. Monoid m => (Pattern loc -> m) -> Pattern loc -> m
Pattern.foldMap' Pattern loc -> PrintAnnotation
f
  where
    f :: Pattern loc -> PrintAnnotation
f = \case
      Pattern.Unbound loc
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Var loc
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Boolean loc
_ Bool
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Int loc
_ Int64
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Nat loc
_ Word64
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Float loc
_ Double
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Text loc
_ Text
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.Char loc
_ Char
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.As loc
_ Pattern loc
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.SequenceLiteral loc
_ [Pattern loc]
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.SequenceOp {} -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.EffectPure loc
_ Pattern loc
_ -> PrintAnnotation
forall a. Monoid a => a
mempty
      Pattern.EffectBind loc
_ ConstructorReference
r [Pattern loc]
_ Pattern loc
_ -> Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
usedTm (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> ConstructorReference -> HashQualified Name
PrettyPrintEnv.patternName PrettyPrintEnv
n ConstructorReference
r
      Pattern.Constructor loc
_ ConstructorReference
r [Pattern loc]
_ ->
        if Reference -> Bool
noImportRefs (ConstructorReference
r ConstructorReference
-> Getting Reference ConstructorReference Reference -> Reference
forall s a. s -> Getting a s a -> a
^. Getting Reference ConstructorReference Reference
forall r s (f :: * -> *).
Functor f =>
(r -> f s)
-> GConstructorReference r -> f (GConstructorReference s)
ConstructorReference.reference_)
          then PrintAnnotation
forall a. Monoid a => a
mempty
          else Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
usedTm (HashQualified Name -> PrintAnnotation)
-> HashQualified Name -> PrintAnnotation
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> ConstructorReference -> HashQualified Name
PrettyPrintEnv.patternName PrettyPrintEnv
n ConstructorReference
r

countHQ :: Set Name -> HQ.HashQualified Name -> PrintAnnotation
countHQ :: Set Name -> HashQualified Name -> PrintAnnotation
countHQ Set Name
used (HQ.NameOnly Name
n)
  -- Names that are marked 'used' aren't considered for `use` clause insertion
  -- So if a variable 'foo' is used, then we won't insert a `use` clause for
  -- the reference `Qux.quaffle.foo`.
  | Just Name
n' <- Name -> Set Name -> Maybe Name
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLE Name
n Set Name
used, Name -> Name -> Bool
Name.endsWith Name
n Name
n' = PrintAnnotation
forall a. Monoid a => a
mempty
countHQ Set Name
_ HashQualified Name
hq = (Name -> PrintAnnotation) -> Maybe Name -> PrintAnnotation
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Name -> PrintAnnotation
countName (HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName HashQualified Name
hq)

countName :: Name -> PrintAnnotation
countName :: Name -> PrintAnnotation
countName Name
n =
  PrintAnnotation
    { $sel:usages:PrintAnnotation :: Map Text (Map Prefix Int)
usages =
        [(Text, Map Prefix Int)] -> Map Text (Map Prefix Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList do
          ([NameSegment]
p, Name
s) <- HasCallStack => Name -> [([NameSegment], Name)]
Name -> [([NameSegment], Name)]
Name.splits Name
n
          (Text, Map Prefix Int) -> [(Text, Map Prefix Int)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Text
Name.toText Name
s, Prefix -> Int -> Map Prefix Int
forall k a. k -> a -> Map k a
Map.singleton ((NameSegment -> Text) -> [NameSegment] -> Prefix
forall a b. (a -> b) -> [a] -> [b]
map NameSegment -> Text
NameSegment.toEscapedText [NameSegment]
p) Int
1)
    }

joinName :: Prefix -> Suffix -> Name
joinName :: Prefix -> Text -> Name
joinName Prefix
p Text
s = HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Prefix -> Text
dotConcat (Prefix -> Text) -> Prefix -> Text
forall a b. (a -> b) -> a -> b
$ Prefix
p Prefix -> Prefix -> Prefix
forall a. [a] -> [a] -> [a]
++ [Text
s]

dotConcat :: [Text] -> Text
dotConcat :: Prefix -> Text
dotConcat = Prefix -> Text
Text.concat (Prefix -> Text) -> (Prefix -> Prefix) -> Prefix -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Prefix -> Prefix
forall a. a -> [a] -> [a]
intersperse Text
"."

-- This predicate is used to keep certain refs out of the FQN elision annotations,
-- so that we don't get `use` statements for them.
--
-- Don't do `use () ()` or `use Pair Pair`.  Tuple syntax generates ().() and Pair.Pair
-- under the covers anyway.  This does mean that if someone is using Pair.Pair directly,
-- then they'll miss out on FQN elision for that.
--
-- Don't do `use builtin.Doc Blob`, `use builtin.Link Term`, or similar.  That avoids
-- unnecessary use statements above Doc literals and termLink/typeLink.
noImportRefs :: Reference -> Bool
noImportRefs :: Reference -> Bool
noImportRefs Reference
r =
  Reference
r
    Reference -> [Reference] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Reference
DD.pairRef,
             Reference
DD.unitRef,
             Reference
DD.docRef,
             Reference
DD.linkRef
           ]

infixl 0 |>

(|>) :: a -> (a -> b) -> b
a
x |> :: forall a b. a -> (a -> b) -> b
|> a -> b
f = a -> b
f a
x

-- This function gets used each time we start printing a new block statement.
-- It decides what extra imports to introduce (returning the full new set), and
-- determines some pretty-printed lines that looks like
--    use A x
--    use B y
-- providing a `[Pretty SyntaxText] -> Pretty SyntaxText` that prepends those
-- lines to the list of lines provided, and then concatenates them.
calcImports ::
  (Var v, Ord v) =>
  Imports ->
  Term3 v PrintAnnotation ->
  (Imports, [Pretty SyntaxText])
calcImports :: forall v.
(Var v, Ord v) =>
Imports
-> Term3 v PrintAnnotation -> (Imports, [Pretty SyntaxText])
calcImports Imports
im Term3 v PrintAnnotation
tm = (Imports
im', Map Prefix (Set Text) -> [Pretty SyntaxText]
forall {t :: * -> *} {r}.
Foldable t =>
Map (t Text) (Set Text) -> [Pretty (SyntaxText' r)]
render (Map Prefix (Set Text) -> [Pretty SyntaxText])
-> Map Prefix (Set Text) -> [Pretty SyntaxText]
forall a b. (a -> b) -> a -> b
$ Map Name (Prefix, Text, Int) -> Map Prefix (Set Text)
getUses Map Name (Prefix, Text, Int)
result)
  where
    -- The guts of this function is a pipeline of transformations and filters, starting from the
    -- PrintAnnotation we built up in printAnnotate.
    -- In `result`, the Name matches Prefix ++ Suffix; and the Int is the number of usages in this scope.
    -- `result` lists all the names we're going to import, and what Prefix we'll use for each.
    result :: Map Name (Prefix, Suffix, Int)
    result :: Map Name (Prefix, Text, Int)
result =
      Map Text (Map Prefix Int)
usages'
        Map Text (Map Prefix Int)
-> (Map Text (Map Prefix Int) -> Map Text (Prefix, Int))
-> Map Text (Prefix, Int)
forall a b. a -> (a -> b) -> b
|> Map Text (Map Prefix Int) -> Map Text (Prefix, Int)
uniqueness
        Map Text (Prefix, Int)
-> (Map Text (Prefix, Int) -> Map Text (Prefix, Int))
-> Map Text (Prefix, Int)
forall a b. a -> (a -> b) -> b
|> Map Text (Prefix, Int) -> Map Text (Prefix, Int)
enoughUsages
        Map Text (Prefix, Int)
-> (Map Text (Prefix, Int) -> Map (Name, Int) (Prefix, Text, Int))
-> Map (Name, Int) (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> Map Text (Prefix, Int) -> Map (Name, Int) (Prefix, Text, Int)
groupAndCountLength
        Map (Name, Int) (Prefix, Text, Int)
-> (Map (Name, Int) (Prefix, Text, Int)
    -> Map Name (Prefix, Text, Int))
-> Map Name (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> Map (Name, Int) (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
forall k1 k2 v.
(Show k1, Show k2, Ord k1, Ord k2) =>
Map (k1, k2) v -> Map k1 v
longestPrefix
        Map Name (Prefix, Text, Int)
-> (Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int))
-> Map Name (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
avoidRepeatsAndClashes
        Map Name (Prefix, Text, Int)
-> (Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int))
-> Map Name (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
narrowestPossible
    usages' :: Map Suffix (Map Prefix Int)
    usages' :: Map Text (Map Prefix Int)
usages' = PrintAnnotation -> Map Text (Map Prefix Int)
usages (PrintAnnotation -> Map Text (Map Prefix Int))
-> PrintAnnotation -> Map Text (Map Prefix Int)
forall a b. (a -> b) -> a -> b
$ Term3 v PrintAnnotation -> PrintAnnotation
forall (f :: * -> *) v a. Term f v a -> a
annotation Term3 v PrintAnnotation
tm
    -- Keep only names P.S where there is no other Q with Q.S also used in this scope.
    uniqueness :: Map Suffix (Map Prefix Int) -> Map Suffix (Prefix, Int)
    uniqueness :: Map Text (Map Prefix Int) -> Map Text (Prefix, Int)
uniqueness Map Text (Map Prefix Int)
m =
      Map Text (Map Prefix Int)
m
        Map Text (Map Prefix Int)
-> (Map Text (Map Prefix Int) -> Map Text (Map Prefix Int))
-> Map Text (Map Prefix Int)
forall a b. a -> (a -> b) -> b
|> (Map Prefix Int -> Bool)
-> Map Text (Map Prefix Int) -> Map Text (Map Prefix Int)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\Map Prefix Int
ps -> Map Prefix Int -> Int
forall k a. Map k a -> Int
Map.size Map Prefix Int
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
        Map Text (Map Prefix Int)
-> (Map Text (Map Prefix Int) -> Map Text (Prefix, Int))
-> Map Text (Prefix, Int)
forall a b. a -> (a -> b) -> b
|> (Map Prefix Int -> (Prefix, Int))
-> Map Text (Map Prefix Int) -> Map Text (Prefix, Int)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([(Prefix, Int)] -> (Prefix, Int)
forall a. HasCallStack => [a] -> a
head ([(Prefix, Int)] -> (Prefix, Int))
-> (Map Prefix Int -> [(Prefix, Int)])
-> Map Prefix Int
-> (Prefix, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Prefix Int -> [(Prefix, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList)
    -- Keep only names where the number of usages in this scope
    --   - is > 1, or
    --   - is 1, and S is an infix operator.
    -- Also drop names with an empty prefix.
    lookupOrDie :: k -> Map k a -> a
lookupOrDie k
s Map k a
m = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
msg (k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
s Map k a
m)
      where
        msg :: a
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"TermPrinter.enoughUsages " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (k, Map k a) -> String
forall a. Show a => a -> String
show (k
s, Map k a
m)

    enoughUsages :: Map Suffix (Prefix, Int) -> Map Suffix (Prefix, Int)
    enoughUsages :: Map Text (Prefix, Int) -> Map Text (Prefix, Int)
enoughUsages Map Text (Prefix, Int)
m =
      Map Text (Prefix, Int) -> Prefix
forall k a. Map k a -> [k]
Map.keys Map Text (Prefix, Int)
m
        Prefix -> (Prefix -> Prefix) -> Prefix
forall a b. a -> (a -> b) -> b
|> (Text -> Bool) -> Prefix -> Prefix
forall a. (a -> Bool) -> [a] -> [a]
filter
          ( \Text
s ->
              let (Prefix
p, Int
i) = Text -> Map Text (Prefix, Int) -> (Prefix, Int)
forall {k} {a}. (Show k, Show a, Ord k) => k -> Map k a -> a
lookupOrDie Text
s Map Text (Prefix, Int)
m
               in (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| (Text -> Bool) -> (Name -> Bool) -> Either Text Name -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
False) Name -> Bool
Name.isSymboly (Text -> Either Text Name
Name.parseTextEither Text
s)) Bool -> Bool -> Bool
&& Bool -> Bool
not (Prefix -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Prefix
p)
          )
        Prefix
-> (Prefix -> [(Text, (Prefix, Int))]) -> [(Text, (Prefix, Int))]
forall a b. a -> (a -> b) -> b
|> (Text -> (Text, (Prefix, Int)))
-> Prefix -> [(Text, (Prefix, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
s -> (Text
s, Text -> Map Text (Prefix, Int) -> (Prefix, Int)
forall {k} {a}. (Show k, Show a, Ord k) => k -> Map k a -> a
lookupOrDie Text
s Map Text (Prefix, Int)
m))
        [(Text, (Prefix, Int))]
-> ([(Text, (Prefix, Int))] -> Map Text (Prefix, Int))
-> Map Text (Prefix, Int)
forall a b. a -> (a -> b) -> b
|> [(Text, (Prefix, Int))] -> Map Text (Prefix, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    -- Group by `Prefix ++ Suffix`, and then by `length Prefix`
    groupAndCountLength :: Map Suffix (Prefix, Int) -> Map (Name, Int) (Prefix, Suffix, Int)
    groupAndCountLength :: Map Text (Prefix, Int) -> Map (Name, Int) (Prefix, Text, Int)
groupAndCountLength Map Text (Prefix, Int)
m =
      Map Text (Prefix, Int) -> [(Text, (Prefix, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Prefix, Int)
m
        [(Text, (Prefix, Int))]
-> ([(Text, (Prefix, Int))]
    -> [((Name, Int), (Prefix, Text, Int))])
-> [((Name, Int), (Prefix, Text, Int))]
forall a b. a -> (a -> b) -> b
|> ((Text, (Prefix, Int)) -> ((Name, Int), (Prefix, Text, Int)))
-> [(Text, (Prefix, Int))] -> [((Name, Int), (Prefix, Text, Int))]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \(Text
s, (Prefix
p, Int
i)) ->
              let n :: Name
n = Prefix -> Text -> Name
joinName Prefix
p Text
s
                  l :: Int
l = Prefix -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Prefix
p
               in ((Name
n, Int
l), (Prefix
p, Text
s, Int
i))
          )
        [((Name, Int), (Prefix, Text, Int))]
-> ([((Name, Int), (Prefix, Text, Int))]
    -> Map (Name, Int) (Prefix, Text, Int))
-> Map (Name, Int) (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> [((Name, Int), (Prefix, Text, Int))]
-> Map (Name, Int) (Prefix, Text, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    -- For each k1, choose the v with the largest k2.
    longestPrefix :: (Show k1, Show k2, Ord k1, Ord k2) => Map (k1, k2) v -> Map k1 v
    longestPrefix :: forall k1 k2 v.
(Show k1, Show k2, Ord k1, Ord k2) =>
Map (k1, k2) v -> Map k1 v
longestPrefix Map (k1, k2) v
m =
      let k1s :: Set k1
k1s = ((k1, k2) -> k1) -> Set (k1, k2) -> Set k1
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (k1, k2) -> k1
forall a b. (a, b) -> a
fst (Set (k1, k2) -> Set k1) -> Set (k1, k2) -> Set k1
forall a b. (a -> b) -> a -> b
$ Map (k1, k2) v -> Set (k1, k2)
forall k a. Map k a -> Set k
Map.keysSet Map (k1, k2) v
m
          k2s :: Map k1 (Set k2)
k2s =
            Set k1
k1s
              Set k1 -> (Set k1 -> Map k1 (Set k2)) -> Map k1 (Set k2)
forall a b. a -> (a -> b) -> b
|> (k1 -> Set k2) -> Set k1 -> Map k1 (Set k2)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet
                ( \k1
k1' ->
                    Map (k1, k2) v -> Set (k1, k2)
forall k a. Map k a -> Set k
Map.keysSet Map (k1, k2) v
m
                      Set (k1, k2) -> (Set (k1, k2) -> Set (k1, k2)) -> Set (k1, k2)
forall a b. a -> (a -> b) -> b
|> ((k1, k2) -> Bool) -> Set (k1, k2) -> Set (k1, k2)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(k1
k1, k2
_) -> k1
k1 k1 -> k1 -> Bool
forall a. Eq a => a -> a -> Bool
== k1
k1')
                      Set (k1, k2) -> (Set (k1, k2) -> Set k2) -> Set k2
forall a b. a -> (a -> b) -> b
|> ((k1, k2) -> k2) -> Set (k1, k2) -> Set k2
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (k1, k2) -> k2
forall a b. (a, b) -> b
snd
                )
          maxk2s :: Map k1 k2
maxk2s = (Set k2 -> k2) -> Map k1 (Set k2) -> Map k1 k2
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Set k2 -> k2
forall a. Ord a => Set a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Map k1 (Set k2)
k2s
          err :: k1 -> k2 -> v
err k1
k1 k2
k2 =
            String -> v
forall a. HasCallStack => String -> a
error (String -> v) -> String -> v
forall a b. (a -> b) -> a -> b
$
              String
"TermPrinter.longestPrefix not found "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (k1, k2) -> String
forall a. Show a => a -> String
show (k1
k1, k2
k2)
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map k1 k2 -> String
forall a. Show a => a -> String
show Map k1 k2
maxk2s
       in (k1 -> k2 -> v) -> Map k1 k2 -> Map k1 v
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\k1
k1 k2
k2 -> v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe (k1 -> k2 -> v
err k1
k1 k2
k2) (Maybe v -> v) -> Maybe v -> v
forall a b. (a -> b) -> a -> b
$ (k1, k2) -> Map (k1, k2) v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (k1
k1, k2
k2) Map (k1, k2) v
m) Map k1 k2
maxk2s
    -- Don't do another `use` for a name for which we've already done one, unless the
    -- new suffix is shorter.
    avoidRepeatsAndClashes :: Map Name (Prefix, Suffix, Int) -> Map Name (Prefix, Suffix, Int)
    avoidRepeatsAndClashes :: Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
avoidRepeatsAndClashes = (Name -> (Prefix, Text, Int) -> Bool)
-> Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey ((Name -> (Prefix, Text, Int) -> Bool)
 -> Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int))
-> (Name -> (Prefix, Text, Int) -> Bool)
-> Map Name (Prefix, Text, Int)
-> Map Name (Prefix, Text, Int)
forall a b. (a -> b) -> a -> b
$
      \Name
n (Prefix
_, Text
s', Int
_) -> case Name -> Imports -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Imports
im of
        Just Text
s -> Text -> Int
Text.length Text
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Text -> Int
Text.length Text
s
        Maybe Text
Nothing -> Bool
True
    -- Is there a strictly smaller block term underneath this one, containing all the usages
    -- of some of the names?  Skip emitting `use` statements for those, so we can do it
    -- further down, closer to the use sites.
    narrowestPossible :: Map Name (Prefix, Suffix, Int) -> Map Name (Prefix, Suffix, Int)
    narrowestPossible :: Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
narrowestPossible Map Name (Prefix, Text, Int)
m = Map Name (Prefix, Text, Int)
m Map Name (Prefix, Text, Int)
-> (Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int))
-> Map Name (Prefix, Text, Int)
forall a b. a -> (a -> b) -> b
|> ((Prefix, Text, Int) -> Bool)
-> Map Name (Prefix, Text, Int) -> Map Name (Prefix, Text, Int)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\(Prefix
p, Text
s, Int
i) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Term3 v PrintAnnotation -> Prefix -> Text -> Int -> Bool
forall v.
(Var v, Ord v) =>
Term3 v PrintAnnotation -> Prefix -> Text -> Int -> Bool
allInSubBlock Term3 v PrintAnnotation
tm Prefix
p Text
s Int
i)
    -- `union` is left-biased, so this can replace existing imports.
    im' :: Imports
im' = Map Name (Prefix, Text, Int) -> Imports
getImportMapAdditions Map Name (Prefix, Text, Int)
result Imports -> Imports -> Imports
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Imports
im
    getImportMapAdditions :: Map Name (Prefix, Suffix, Int) -> Map Name Suffix
    getImportMapAdditions :: Map Name (Prefix, Text, Int) -> Imports
getImportMapAdditions = ((Prefix, Text, Int) -> Text)
-> Map Name (Prefix, Text, Int) -> Imports
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Prefix
_, Text
s, Int
_) -> Text
s)
    getUses :: Map Name (Prefix, Suffix, Int) -> Map Prefix (Set Suffix)
    getUses :: Map Name (Prefix, Text, Int) -> Map Prefix (Set Text)
getUses Map Name (Prefix, Text, Int)
m =
      Map Name (Prefix, Text, Int) -> [(Prefix, Text, Int)]
forall k a. Map k a -> [a]
Map.elems Map Name (Prefix, Text, Int)
m
        [(Prefix, Text, Int)]
-> ([(Prefix, Text, Int)] -> [(Prefix, Set Text)])
-> [(Prefix, Set Text)]
forall a b. a -> (a -> b) -> b
|> ((Prefix, Text, Int) -> (Prefix, Set Text))
-> [(Prefix, Text, Int)] -> [(Prefix, Set Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Prefix
p, Text
s, Int
_) -> (Prefix
p, Text -> Set Text
forall a. a -> Set a
Set.singleton Text
s))
        [(Prefix, Set Text)]
-> ([(Prefix, Set Text)] -> Map Prefix (Set Text))
-> Map Prefix (Set Text)
forall a b. a -> (a -> b) -> b
|> (Set Text -> Set Text -> Set Text)
-> [(Prefix, Set Text)] -> Map Prefix (Set Text)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union
    render :: Map (t Text) (Set Text) -> [Pretty (SyntaxText' r)]
render Map (t Text) (Set Text)
m =
      (t Text -> Set Text -> Pretty (SyntaxText' r))
-> Map (t Text) (Set Text) -> Map (t Text) (Pretty (SyntaxText' r))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
        ( \t Text
p Set Text
ss ->
            Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.UseKeyword (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
"use ")
              Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.UsePrefix (Pretty (SyntaxText' r)
-> (Text -> Pretty (SyntaxText' r))
-> t Text
-> Pretty (SyntaxText' r)
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
".") (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l (String -> Pretty (SyntaxText' r))
-> (Text -> String) -> Text -> Pretty (SyntaxText' r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) t Text
p)
              Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
" "
              Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.UseSuffix (Pretty (SyntaxText' r)
-> (Text -> Pretty (SyntaxText' r))
-> Prefix
-> Pretty (SyntaxText' r)
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l String
" ") (String -> Pretty (SyntaxText' r)
forall s. IsString s => String -> Pretty s
l (String -> Pretty (SyntaxText' r))
-> (Text -> String) -> Text -> Pretty (SyntaxText' r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) (Set Text -> Prefix
forall a. Set a -> [a]
Set.toList Set Text
ss))
        )
        Map (t Text) (Set Text)
m
        Map (t Text) (Pretty (SyntaxText' r))
-> (Map (t Text) (Pretty (SyntaxText' r))
    -> [(t Text, Pretty (SyntaxText' r))])
-> [(t Text, Pretty (SyntaxText' r))]
forall a b. a -> (a -> b) -> b
|> Map (t Text) (Pretty (SyntaxText' r))
-> [(t Text, Pretty (SyntaxText' r))]
forall k a. Map k a -> [(k, a)]
Map.toList
        [(t Text, Pretty (SyntaxText' r))]
-> ([(t Text, Pretty (SyntaxText' r))] -> [Pretty (SyntaxText' r)])
-> [Pretty (SyntaxText' r)]
forall a b. a -> (a -> b) -> b
|> ((t Text, Pretty (SyntaxText' r)) -> Pretty (SyntaxText' r))
-> [(t Text, Pretty (SyntaxText' r))] -> [Pretty (SyntaxText' r)]
forall a b. (a -> b) -> [a] -> [b]
map (t Text, Pretty (SyntaxText' r)) -> Pretty (SyntaxText' r)
forall a b. (a, b) -> b
snd

-- Given a block term and a name (Prefix, Suffix) of interest, is there a
-- strictly smaller blockterm within it, containing all usages of that name?
-- A blockterm is a place where the syntax lets us put a use statement, like the
-- branches of an if/then/else.
-- We traverse the block terms by traversing the whole subtree with ABT.find,
-- and paying attention to those subterms that look like a blockterm.
-- This is complicated by the fact that you can't always tell if a term is a
-- blockterm just by looking at it: in some cases you can only tell when you can
-- see it in the context of the wider term that contains it. So actually we
-- traverse the tree, at each term looking for child terms that are block terms,
-- and see if any of those contain all the usages of the name.
-- Cut out the occurrences of "const id $" to get tracing.
allInSubBlock ::
  (Var v, Ord v) =>
  Term3 v PrintAnnotation ->
  Prefix ->
  Suffix ->
  Int ->
  Bool
allInSubBlock :: forall v.
(Var v, Ord v) =>
Term3 v PrintAnnotation -> Prefix -> Text -> Int -> Bool
allInSubBlock Term3 v PrintAnnotation
tm Prefix
p Text
s Int
i =
  let found :: [Term3 v PrintAnnotation]
found = [[Term3 v PrintAnnotation]] -> [Term3 v PrintAnnotation]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Term3 v PrintAnnotation]] -> [Term3 v PrintAnnotation])
-> [[Term3 v PrintAnnotation]] -> [Term3 v PrintAnnotation]
forall a b. (a -> b) -> a -> b
$ (Term3 v PrintAnnotation -> FindAction [Term3 v PrintAnnotation])
-> Term3 v PrintAnnotation -> [[Term3 v PrintAnnotation]]
forall v (f :: * -> *) a x.
(Ord v, Foldable f, Functor f) =>
(Term f v a -> FindAction x) -> Term f v a -> [x]
ABT.find Term3 v PrintAnnotation -> FindAction [Term3 v PrintAnnotation]
finder Term3 v PrintAnnotation
tm
      result :: Bool
result = (Term3 v PrintAnnotation -> Bool)
-> [Term3 v PrintAnnotation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Term3 v PrintAnnotation -> Term3 v PrintAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
/= Term3 v PrintAnnotation
tm) [Term3 v PrintAnnotation]
found
      tr :: a -> a
tr =
        a -> a
forall a. a -> a
id
   in Bool -> Bool
forall a. a -> a
tr Bool
result
  where
    getUsages :: Term3 v PrintAnnotation -> Int
getUsages Term3 v PrintAnnotation
t =
      Term3 v PrintAnnotation -> PrintAnnotation
forall (f :: * -> *) v a. Term f v a -> a
annotation Term3 v PrintAnnotation
t
        PrintAnnotation
-> (PrintAnnotation -> Map Text (Map Prefix Int))
-> Map Text (Map Prefix Int)
forall a b. a -> (a -> b) -> b
|> PrintAnnotation -> Map Text (Map Prefix Int)
usages
        Map Text (Map Prefix Int)
-> (Map Text (Map Prefix Int) -> Maybe (Map Prefix Int))
-> Maybe (Map Prefix Int)
forall a b. a -> (a -> b) -> b
|> Text -> Map Text (Map Prefix Int) -> Maybe (Map Prefix Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
s
        Maybe (Map Prefix Int)
-> (Maybe (Map Prefix Int) -> Maybe (Maybe Int))
-> Maybe (Maybe Int)
forall a b. a -> (a -> b) -> b
|> (Map Prefix Int -> Maybe Int)
-> Maybe (Map Prefix Int) -> Maybe (Maybe Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Prefix -> Map Prefix Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Prefix
p)
        Maybe (Maybe Int) -> (Maybe (Maybe Int) -> Maybe Int) -> Maybe Int
forall a b. a -> (a -> b) -> b
|> Maybe (Maybe Int) -> Maybe Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
        Maybe Int -> (Maybe Int -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0
    finder :: Term3 v PrintAnnotation -> FindAction [Term3 v PrintAnnotation]
finder Term3 v PrintAnnotation
t =
      let result :: FindAction [Term3 v PrintAnnotation]
result =
            let i' :: Int
i' = Term3 v PrintAnnotation -> Int
getUsages Term3 v PrintAnnotation
t
             in if Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i
                  then FindAction [Term3 v PrintAnnotation]
forall x. FindAction x
ABT.Prune
                  else
                    let found :: [Term3 v PrintAnnotation]
found = (Term3 v PrintAnnotation -> Bool)
-> [Term3 v PrintAnnotation] -> [Term3 v PrintAnnotation]
forall a. (a -> Bool) -> [a] -> [a]
filter Term3 v PrintAnnotation -> Bool
hit ([Term3 v PrintAnnotation] -> [Term3 v PrintAnnotation])
-> [Term3 v PrintAnnotation] -> [Term3 v PrintAnnotation]
forall a b. (a -> b) -> a -> b
$ Term3 v PrintAnnotation -> [Term3 v PrintAnnotation]
forall a ap at v vt.
(Var vt, Var v) =>
Term2 vt at ap v a -> [Term2 vt at ap v a]
immediateChildBlockTerms Term3 v PrintAnnotation
t
                     in if Int
i' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& Bool -> Bool
not ([Term3 v PrintAnnotation] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term3 v PrintAnnotation]
found)
                          then [Term3 v PrintAnnotation] -> FindAction [Term3 v PrintAnnotation]
forall x. x -> FindAction x
ABT.Found [Term3 v PrintAnnotation]
found
                          else FindAction [Term3 v PrintAnnotation]
forall x. FindAction x
ABT.Continue
          -- children =
          --   concatMap
          --     (\t -> "child: " ++ show t ++ "\n")
          --     ( immediateChildBlockTerms t
          --     )
          tr :: a -> a
tr =
            a -> a
forall a. a -> a
id
       in FindAction [Term3 v PrintAnnotation]
-> FindAction [Term3 v PrintAnnotation]
forall a. a -> a
tr FindAction [Term3 v PrintAnnotation]
result
    hit :: Term3 v PrintAnnotation -> Bool
hit Term3 v PrintAnnotation
t = Term3 v PrintAnnotation -> Int
getUsages Term3 v PrintAnnotation
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i

-- Return any blockterms at or immediately under this term. Has to match the
-- places in the syntax that get a call to `calcImports` in `pretty0`.
-- AST nodes that do a calcImports in pretty0, in order to try and emit a `use`
-- statement, need to be emitted also by this function, otherwise the `use`
-- statement may come out at an enclosing scope instead.
immediateChildBlockTerms ::
  forall a ap at v vt. (Var vt, Var v) => Term2 vt at ap v a -> [Term2 vt at ap v a]
immediateChildBlockTerms :: forall a ap at v vt.
(Var vt, Var v) =>
Term2 vt at ap v a -> [Term2 vt at ap v a]
immediateChildBlockTerms = \case
  LetBlock [LetBindings v (Term2 vt at ap v a)]
bs Term2 vt at ap v a
e -> (LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a])
-> [LetBindings v (Term2 vt at ap v a)] -> [Term2 vt at ap v a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a]
doLet [LetBindings v (Term2 vt at ap v a)]
bs [Term2 vt at ap v a]
-> [Term2 vt at ap v a] -> [Term2 vt at ap v a]
forall a. [a] -> [a] -> [a]
++ Term2 vt at ap v a -> [Term2 vt at ap v a]
forall {v} {vt} {at} {ap} {a}.
Var v =>
Term2 vt at ap v a -> [Term2 vt at ap v a]
handleDelay Term2 vt at ap v a
e
  Term2 vt at ap v a
_ -> []
  where
    handleDelay :: Term2 vt at ap v a -> [Term2 vt at ap v a]
handleDelay (Delay' Term2 vt at ap v a
b) | Term2 vt at ap v a -> Bool
forall vt at ap v a. Term2 vt at ap v a -> Bool
isLet Term2 vt at ap v a
b = [Term2 vt at ap v a
b]
    handleDelay Term2 vt at ap v a
_ = []
    doLet :: LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a]
    doLet :: LetBindings v (Term2 vt at ap v a) -> [Term2 vt at ap v a]
doLet = \case
      LetBindings [(v, Term2 vt at ap v a)]
bindings -> ((v, Term2 vt at ap v a) -> [Term2 vt at ap v a])
-> [(v, Term2 vt at ap v a)] -> [Term2 vt at ap v a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (v, Term2 vt at ap v a) -> [Term2 vt at ap v a]
forall {v} {v} {vt} {at} {ap} {a}.
(Var v, Show v, Show vt) =>
(v, Term (F vt at ap) v a) -> [Term (F vt at ap) v a]
doLet2 [(v, Term2 vt at ap v a)]
bindings
      LetrecBindings [(v, Term2 vt at ap v a)]
bindings -> ((v, Term2 vt at ap v a) -> [Term2 vt at ap v a])
-> [(v, Term2 vt at ap v a)] -> [Term2 vt at ap v a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (v, Term2 vt at ap v a) -> [Term2 vt at ap v a]
forall {v} {v} {vt} {at} {ap} {a}.
(Var v, Show v, Show vt) =>
(v, Term (F vt at ap) v a) -> [Term (F vt at ap) v a]
doLet2 [(v, Term2 vt at ap v a)]
bindings
    doLet2 :: (v, Term (F vt at ap) v a) -> [Term (F vt at ap) v a]
doLet2 (v
v, Ann' Term (F vt at ap) v a
tm Type vt at
_) = (v, Term (F vt at ap) v a) -> [Term (F vt at ap) v a]
doLet2 (v
v, Term (F vt at ap) v a
tm)
    -- we don't consider 'body' to be a place we can insert a `use`
    -- clause unless it's already a let block. This avoids silliness like:
    --   x = 1 + 1
    -- turning into
    --   x =
    --    use Nat +
    --    1 + 1
    doLet2 (v
v, LamsNamedOpt' [v]
_ Term (F vt at ap) v a
body) = [Term (F vt at ap) v a
body | Bool -> Bool
not (v -> Bool
forall v. Var v => v -> Bool
Var.isAction v
v), Term (F vt at ap) v a -> Bool
forall vt at ap v a. Term2 vt at ap v a -> Bool
isLet Term (F vt at ap) v a
body]
    doLet2 (v, Term (F vt at ap) v a)
t = String -> [Any] -> [Term (F vt at ap) v a]
forall a. HasCallStack => String -> a
error ((v, Term (F vt at ap) v a) -> String
forall a. Show a => a -> String
show (v, Term (F vt at ap) v a)
t) []

isSoftHangable :: (Var v) => Term2 vt at ap v a -> Bool
-- isSoftHangable (Delay' d) = isLet d || isSoftHangable d || case d of
--    Match' scrute cases -> isDestructuringBind scrute cases
--    _ -> False
isSoftHangable :: forall v vt at ap a. Var v => Term2 vt at ap v a -> Bool
isSoftHangable (Delay' Term2 vt at ap v a
_) = Bool
True --
isSoftHangable (LamsNamedMatch' [] [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)]
_) = Bool
True
isSoftHangable (Match' Term2 vt at ap v a
scrute [MatchCase ap (Term2 vt at ap v a)]
cases) = Bool -> Bool
not (Term2 vt at ap v a -> [MatchCase ap (Term2 vt at ap v a)] -> Bool
forall v (f :: * -> *) a loc.
Ord v =>
Term f v a -> [MatchCase loc (Term f v a)] -> Bool
isDestructuringBind Term2 vt at ap v a
scrute [MatchCase ap (Term2 vt at ap v a)]
cases)
isSoftHangable Term2 vt at ap v a
_ = Bool
False

isLet :: Term2 vt at ap v a -> Bool
isLet :: forall vt at ap v a. Term2 vt at ap v a -> Bool
isLet (Let1Named' {}) = Bool
True
isLet (LetRecNamed' {}) = Bool
True
isLet Term (F vt at ap) v a
_ = Bool
False

-- Matches with a single case, no variable shadowing, and where the pattern
-- has no literals are treated as destructuring bind, for instance:
--   match blah with (x,y) -> body
-- BECOMES
--   (x,y) = blah
--   body
-- BUT
--   match (y,x) with (x,y) -> body
-- Has shadowing, is rendered as a regular `match`.
--   match blah with 42 -> body
-- Pattern has (is) a literal, rendered as a regular match (rather than `42 = blah; body`)
isDestructuringBind :: (Ord v) => ABT.Term f v a -> [MatchCase loc (ABT.Term f v a)] -> Bool
isDestructuringBind :: forall v (f :: * -> *) a loc.
Ord v =>
Term f v a -> [MatchCase loc (Term f v a)] -> Bool
isDestructuringBind Term f v a
scrutinee [MatchCase Pattern loc
pat Maybe (Term f v a)
_ (ABT.AbsN' [v]
vs Term f v a
_)] =
  (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Term f v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term f v a
scrutinee) [v]
vs Bool -> Bool -> Bool
&& Bool -> Bool
not (Pattern loc -> Bool
forall {loc}. Pattern loc -> Bool
hasLiteral Pattern loc
pat)
  where
    hasLiteral :: Pattern loc -> Bool
hasLiteral Pattern loc
p = case Pattern loc
p of
      Pattern.Int loc
_ Int64
_ -> Bool
True
      Pattern.Boolean loc
_ Bool
_ -> Bool
True
      Pattern.Nat loc
_ Word64
_ -> Bool
True
      Pattern.Float loc
_ Double
_ -> Bool
True
      Pattern.Text loc
_ Text
_ -> Bool
True
      Pattern.Char loc
_ Char
_ -> Bool
True
      Pattern.Constructor loc
_ ConstructorReference
_ [Pattern loc]
ps -> (Pattern loc -> Bool) -> [Pattern loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pattern loc -> Bool
hasLiteral [Pattern loc]
ps
      Pattern.As loc
_ Pattern loc
p -> Pattern loc -> Bool
hasLiteral Pattern loc
p
      Pattern.EffectPure loc
_ Pattern loc
p -> Pattern loc -> Bool
hasLiteral Pattern loc
p
      Pattern.EffectBind loc
_ ConstructorReference
_ [Pattern loc]
ps Pattern loc
pk -> (Pattern loc -> Bool) -> [Pattern loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pattern loc -> Bool
hasLiteral (Pattern loc
pk Pattern loc -> [Pattern loc] -> [Pattern loc]
forall a. a -> [a] -> [a]
: [Pattern loc]
ps)
      Pattern.SequenceLiteral loc
_ [Pattern loc]
ps -> (Pattern loc -> Bool) -> [Pattern loc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pattern loc -> Bool
hasLiteral [Pattern loc]
ps
      Pattern.SequenceOp loc
_ Pattern loc
p SeqOp
_ Pattern loc
p2 -> Pattern loc -> Bool
hasLiteral Pattern loc
p Bool -> Bool -> Bool
|| Pattern loc -> Bool
hasLiteral Pattern loc
p2
      Pattern.Var loc
_ -> Bool
False
      Pattern.Unbound loc
_ -> Bool
False
isDestructuringBind Term f v a
_ [MatchCase loc (Term f v a)]
_ = Bool
False

isBlock :: (Var v, Ord v) => Term2 vt at ap v a -> Bool
isBlock :: forall v vt at ap a. (Var v, Ord v) => Term2 vt at ap v a -> Bool
isBlock Term2 vt at ap v a
tm =
  case Term2 vt at ap v a
tm of
    If' {} -> Bool
True
    Handle' Term2 vt at ap v a
_ Term2 vt at ap v a
_ -> Bool
True
    Match' Term2 vt at ap v a
_ [MatchCase ap (Term2 vt at ap v a)]
_ -> Bool
True
    LetBlock [LetBindings v (Term2 vt at ap v a)]
_ Term2 vt at ap v a
_ -> Bool
True
    DDelay' Term2 vt at ap v a
_ -> Bool
True
    Delay' Term2 vt at ap v a
_ -> Bool
True
    Term2 vt at ap v a
_ -> Bool
False

-- A `LetBindings` is either:
--

-- * A list of nonrecusrive lets (e.g. let x = ... in let y = ... in let z = ... in ...), where each binding is in

--   scope for all subsequent bindings.
--
--   In made-up syntax:
--
--     let
--       x = ...
--     in
--       let
--         y = ...
--       in
--         let
--           z = ...
--         in
--           body
--

-- * A single letrec's bindings, where each binding is in scope for all subsequent bindings.

--
--   In made-up syntax:
--
--     letrec
--       x = ...
--       y = ...
--       z = ...
--     in
--       body
data LetBindings v term
  = LetBindings [(v, term)]
  | LetrecBindings [(v, term)]

-- | A group of let bindings (with all bound variables cached at the top level for efficiency).
--
-- The sequence has an invariant: no two `LetBindings` in a row (that would be a single `LetBindings`).
--
-- For example, the bindings
--
--   a = ...
--   b = ...
--   c = ...
--   d = ...
--   e = ...
--   f = ...
--   body
--
-- might be two lets `a` and `b`, followed by a letrec `c` and `d`, followed by a different letrec `e`, `f`:
--
--   let
--     a = ...
--   in
--     let
--       b = ...
--     in
--       letrec
--         c = ...
--         d = ...
--       in
--         letrec
--           e = ...
--           f = ...
--         in
--           body
data LetBindingsGroups v term
  = LetBindingsGroups (Set v) (Seq (LetBindings v term))

instance (Ord v) => Semigroup (LetBindingsGroups v term) where
  LetBindingsGroups Set v
vs1 Seq (LetBindings v term)
bs1 <> :: LetBindingsGroups v term
-> LetBindingsGroups v term -> LetBindingsGroups v term
<> LetBindingsGroups Set v
vs2 Seq (LetBindings v term)
bs2 =
    Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
forall v term.
Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
LetBindingsGroups (Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set v
vs1 Set v
vs2) (Seq (LetBindings v term)
bs1 Seq (LetBindings v term)
-> Seq (LetBindings v term) -> Seq (LetBindings v term)
forall a. Semigroup a => a -> a -> a
<> Seq (LetBindings v term)
bs2)

letBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term
letBindingsToLetBindingsGroups :: forall v term. Ord v => [(v, term)] -> LetBindingsGroups v term
letBindingsToLetBindingsGroups [(v, term)]
bindings =
  Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
forall v term.
Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
LetBindingsGroups ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList (((v, term) -> v) -> [(v, term)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, term) -> v
forall a b. (a, b) -> a
fst [(v, term)]
bindings)) (LetBindings v term -> Seq (LetBindings v term)
forall a. a -> Seq a
Seq.singleton ([(v, term)] -> LetBindings v term
forall v term. [(v, term)] -> LetBindings v term
LetBindings [(v, term)]
bindings))

letrecBindingsToLetBindingsGroups :: (Ord v) => [(v, term)] -> LetBindingsGroups v term
letrecBindingsToLetBindingsGroups :: forall v term. Ord v => [(v, term)] -> LetBindingsGroups v term
letrecBindingsToLetBindingsGroups [(v, term)]
bindings =
  Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
forall v term.
Set v -> Seq (LetBindings v term) -> LetBindingsGroups v term
LetBindingsGroups ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList (((v, term) -> v) -> [(v, term)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, term) -> v
forall a b. (a, b) -> a
fst [(v, term)]
bindings)) (LetBindings v term -> Seq (LetBindings v term)
forall a. a -> Seq a
Seq.singleton ([(v, term)] -> LetBindings v term
forall v term. [(v, term)] -> LetBindings v term
LetrecBindings [(v, term)]
bindings))

pattern LetBlock ::
  (Ord v) =>
  [LetBindings v (Term2 vt at ap v a)] ->
  Term2 vt at ap v a ->
  Term2 vt at ap v a
pattern $mLetBlock :: forall {r} {v} {vt} {at} {ap} {a}.
Ord v =>
Term2 vt at ap v a
-> ([LetBindings v (Term2 vt at ap v a)]
    -> Term2 vt at ap v a -> r)
-> ((# #) -> r)
-> r
LetBlock bindings body <-
  (unLetBlock -> Just (LetBindingsGroups _ (Foldable.toList @Seq -> bindings), body))

-- Collects nested let/let rec blocks into one minimally nested block.
-- Handy because `let` and `let rec` blocks get rendered the same way.
-- We preserve nesting when the inner block shadows definitions in the
-- outer block.
unLetBlock ::
  forall a ap at v vt.
  (Ord v) =>
  Term2 vt at ap v a ->
  Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
unLetBlock :: forall a ap at v vt.
Ord v =>
Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
unLetBlock = Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
rec
  where
    dontIntersect :: LetBindingsGroups v term -> LetBindingsGroups v term -> Bool
    dontIntersect :: forall term.
LetBindingsGroups v term -> LetBindingsGroups v term -> Bool
dontIntersect (LetBindingsGroups Set v
xs Seq (LetBindings v term)
_) (LetBindingsGroups Set v
ys Seq (LetBindings v term)
_) =
      Set v -> Set v -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set v
xs Set v
ys

    rec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
    rec :: Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
rec Term2 vt at ap v a
t = case Term2 vt at ap v a
-> Maybe (Bool, [(v, Term2 vt at ap v a)], Term2 vt at ap v a)
forall vt at ap v a.
Term2 vt at ap v a
-> Maybe (Bool, [(v, Term2 vt at ap v a)], Term2 vt at ap v a)
unLetRecNamed Term2 vt at ap v a
t of
      Maybe (Bool, [(v, Term2 vt at ap v a)], Term2 vt at ap v a)
Nothing -> Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
nonrec Term2 vt at ap v a
t
      Just (Bool
_isTop, [(v, Term2 vt at ap v a)]
bindings0, Term2 vt at ap v a
body) ->
        let bindings :: LetBindingsGroups v (Term2 vt at ap v a)
bindings = [(v, Term2 vt at ap v a)]
-> LetBindingsGroups v (Term2 vt at ap v a)
forall v term. Ord v => [(v, term)] -> LetBindingsGroups v term
letrecBindingsToLetBindingsGroups [(v, Term2 vt at ap v a)]
bindings0
         in case Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
rec Term2 vt at ap v a
body of
              Just (LetBindingsGroups v (Term2 vt at ap v a)
innerBindings, Term2 vt at ap v a
innerBody)
                | LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a) -> Bool
forall term.
LetBindingsGroups v term -> LetBindingsGroups v term -> Bool
dontIntersect LetBindingsGroups v (Term2 vt at ap v a)
bindings LetBindingsGroups v (Term2 vt at ap v a)
innerBindings ->
                    (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
forall a. a -> Maybe a
Just (LetBindingsGroups v (Term2 vt at ap v a)
bindings LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a)
forall a. Semigroup a => a -> a -> a
<> LetBindingsGroups v (Term2 vt at ap v a)
innerBindings, Term2 vt at ap v a
innerBody)
              Maybe
  (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
_ -> (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
forall a. a -> Maybe a
Just (LetBindingsGroups v (Term2 vt at ap v a)
bindings, Term2 vt at ap v a
body)

    nonrec :: Term2 vt at ap v a -> Maybe (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
    nonrec :: Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
nonrec Term2 vt at ap v a
t = case Term2 vt at ap v a
-> Maybe ([(Bool, v, Term2 vt at ap v a)], Term2 vt at ap v a)
forall vt at ap v a.
Term2 vt at ap v a
-> Maybe ([(Bool, v, Term2 vt at ap v a)], Term2 vt at ap v a)
unLet Term2 vt at ap v a
t of
      Maybe ([(Bool, v, Term2 vt at ap v a)], Term2 vt at ap v a)
Nothing -> Maybe
  (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
forall a. Maybe a
Nothing
      Just ([(Bool, v, Term2 vt at ap v a)]
bindings0, Term2 vt at ap v a
body) ->
        let bindings :: LetBindingsGroups v (Term2 vt at ap v a)
bindings = [(v, Term2 vt at ap v a)]
-> LetBindingsGroups v (Term2 vt at ap v a)
forall v term. Ord v => [(v, term)] -> LetBindingsGroups v term
letBindingsToLetBindingsGroups [(v
v, Term2 vt at ap v a
b) | (Bool
_, v
v, Term2 vt at ap v a
b) <- [(Bool, v, Term2 vt at ap v a)]
bindings0]
         in case Term2 vt at ap v a
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
rec Term2 vt at ap v a
body of
              Just (LetBindingsGroups v (Term2 vt at ap v a)
innerBindings, Term2 vt at ap v a
innerBody)
                | LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a) -> Bool
forall term.
LetBindingsGroups v term -> LetBindingsGroups v term -> Bool
dontIntersect LetBindingsGroups v (Term2 vt at ap v a)
bindings LetBindingsGroups v (Term2 vt at ap v a)
innerBindings ->
                    (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
forall a. a -> Maybe a
Just (LetBindingsGroups v (Term2 vt at ap v a)
bindings LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a)
-> LetBindingsGroups v (Term2 vt at ap v a)
forall a. Semigroup a => a -> a -> a
<> LetBindingsGroups v (Term2 vt at ap v a)
innerBindings, Term2 vt at ap v a
innerBody)
              Maybe
  (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
_ -> (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
-> Maybe
     (LetBindingsGroups v (Term2 vt at ap v a), Term2 vt at ap v a)
forall a. a -> Maybe a
Just (LetBindingsGroups v (Term2 vt at ap v a)
bindings, Term2 vt at ap v a
body)

pattern LamsNamedMatch' ::
  (Var v) =>
  [v] ->
  [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)] ->
  Term2 vt at ap v a
pattern $mLamsNamedMatch' :: forall {r} {v} {ap} {vt} {at} {a}.
Var v =>
Term2 vt at ap v a
-> ([v]
    -> [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)]
    -> r)
-> ((# #) -> r)
-> r
LamsNamedMatch' vs branches <- (unLamsMatch' -> Just (vs, branches))

-- This function is used to detect places where lambda case syntax can be used.
-- When given lambdas of a form that corresponds to a lambda case, it returns
-- `Just (varsBeforeCases, branches)`. Leading vars are the vars that should be
-- shown to the left of the `-> cases`.
--
-- For instance, if given this term:
--
--   x y z -> match z with
--     [] -> "empty"
--     (h +: t) -> "nonempty"
--
-- this function will return Just ([x,y], [[] -> "empty", (h +: t) -> "nonempty"])
-- and it would be rendered as
--
--   x y -> cases []     -> "empty"
--                h +: t -> "nonempty"
--
-- Given this term
--
--   x y z -> match (y, z) with
--     ("a", "b") -> "abba"
--     (x, y) -> y ++ x
--
-- this function will return Just ([x], [ "a" "b" -> "abba", x y -> y ++ x])
-- and it would be rendered as `x -> cases "a", "b" -> "abba"
--                                         x,    y  -> y ++ x
--
-- This function returns `Nothing` in cases where the term it is given isn't
-- a lambda, or when the lambda isn't in the correct form for lambda cases.
-- (For instance, `x -> match (x, 42) with ...` can't be written using
-- lambda case)
unLamsMatch' ::
  (Var v) =>
  Term2 vt at ap v a ->
  Maybe ([v], [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
unLamsMatch' :: forall v vt at ap a.
Var v =>
Term2 vt at ap v a
-> Maybe
     ([v],
      [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
unLamsMatch' Term2 vt at ap v a
t = case Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a)
forall v vt at ap a.
Var v =>
Term2 vt at ap v a -> Maybe ([v], Term2 vt at ap v a)
unLamsUntilDelay' Term2 vt at ap v a
t of
  -- x -> match x with pat -> ...
  --   becomes
  -- cases pat -> ...
  Just ([v] -> [v]
forall a. [a] -> [a]
reverse -> (v
v1 : [v]
vs), Match' (Var' v
v1') [MatchCase ap (Term2 vt at ap v a)]
branches)
    | -- if `v1'` is referenced in any of the branches, we can't use lambda case
      -- syntax as we need to keep the `v1'` name that was introduced
      v
v1 v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
v1' Bool -> Bool -> Bool
&& v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v1' ([Set v] -> Set v
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set v] -> Set v) -> [Set v] -> Set v
forall a b. (a -> b) -> a -> b
$ MatchCase ap (Term2 vt at ap v a) -> Set v
forall {a} {loc} {f :: * -> *} {a}.
Ord a =>
MatchCase loc (Term f a a) -> Set a
freeVars (MatchCase ap (Term2 vt at ap v a) -> Set v)
-> [MatchCase ap (Term2 vt at ap v a)] -> [Set v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchCase ap (Term2 vt at ap v a)]
branches) ->
        ([v],
 [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
-> Maybe
     ([v],
      [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
forall a. a -> Maybe a
Just ([v] -> [v]
forall a. [a] -> [a]
reverse [v]
vs, [([Pattern ap
p], Maybe (Term2 vt at ap v a)
guard, Term2 vt at ap v a
body) | MatchCase Pattern ap
p Maybe (Term2 vt at ap v a)
guard Term2 vt at ap v a
body <- [MatchCase ap (Term2 vt at ap v a)]
branches])
  -- x y z -> match (x,y,z) with (pat1, pat2, pat3) -> ...
  --   becomes
  -- cases pat1 pat2 pat3 -> ...`
  Just ([v] -> [v]
forall a. [a] -> [a]
reverse -> vs :: [v]
vs@(v
_ : [v]
_), Match' (TupleTerm' [Term2 vt at ap v a]
scrutes) [MatchCase ap (Term2 vt at ap v a)]
branches)
    | [v] -> [Term2 vt at ap v a] -> Bool
forall {a} {f :: * -> *} {a}. Eq a => [a] -> [Term f a a] -> Bool
multiway [v]
vs ([Term2 vt at ap v a] -> [Term2 vt at ap v a]
forall a. [a] -> [a]
reverse [Term2 vt at ap v a]
scrutes)
        Bool -> Bool -> Bool
&&
        -- (as above) if any of the vars are referenced in any of the branches,
        -- we need to keep the names introduced by the lambda and can't use
        -- lambda case syntax
        (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all v -> Bool
notFree (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
take Int
len [v]
vs)
        Bool -> Bool -> Bool
&& (MatchCase ap (Term2 vt at ap v a) -> Bool)
-> [MatchCase ap (Term2 vt at ap v a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MatchCase ap (Term2 vt at ap v a) -> Bool
isRightArity [MatchCase ap (Term2 vt at ap v a)]
branches
        Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> -- all patterns need to match arity of scrutes
        ([v],
 [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
-> Maybe
     ([v],
      [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
forall a. a -> Maybe a
Just ([v] -> [v]
forall a. [a] -> [a]
reverse (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
len [v]
vs), [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)]
branches')
    where
      isRightArity :: MatchCase ap (Term2 vt at ap v a) -> Bool
isRightArity (MatchCase (TuplePattern [Pattern ap]
ps) Maybe (Term2 vt at ap v a)
_ Term2 vt at ap v a
_) = [Pattern ap] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern ap]
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
      isRightArity MatchCase {} = Bool
False
      len :: Int
len = [Term2 vt at ap v a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term2 vt at ap v a]
scrutes
      fvs :: Set v
fvs = [Set v] -> Set v
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set v] -> Set v) -> [Set v] -> Set v
forall a b. (a -> b) -> a -> b
$ MatchCase ap (Term2 vt at ap v a) -> Set v
forall {a} {loc} {f :: * -> *} {a}.
Ord a =>
MatchCase loc (Term f a a) -> Set a
freeVars (MatchCase ap (Term2 vt at ap v a) -> Set v)
-> [MatchCase ap (Term2 vt at ap v a)] -> [Set v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchCase ap (Term2 vt at ap v a)]
branches
      notFree :: v -> Bool
notFree v
v = v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v Set v
fvs
      branches' :: [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)]
branches' = [([Pattern ap]
ps, Maybe (Term2 vt at ap v a)
guard, Term2 vt at ap v a
body) | MatchCase (TuplePattern [Pattern ap]
ps) Maybe (Term2 vt at ap v a)
guard Term2 vt at ap v a
body <- [MatchCase ap (Term2 vt at ap v a)]
branches]
  Maybe ([v], Term2 vt at ap v a)
_ -> Maybe
  ([v],
   [([Pattern ap], Maybe (Term2 vt at ap v a), Term2 vt at ap v a)])
forall a. Maybe a
Nothing
  where
    -- multiway vs tms checks that length tms <= length vs, and their common prefix
    -- is all matching variables
    multiway :: [a] -> [Term f a a] -> Bool
multiway [a]
_ [] = Bool
True
    multiway (a
h : [a]
t) (Var' a
h2 : [Term f a a]
t2) | a
h a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
h2 = [a] -> [Term f a a] -> Bool
multiway [a]
t [Term f a a]
t2
    multiway [a]
_ [Term f a a]
_ = Bool
False
    freeVars :: MatchCase loc (Term f a a) -> Set a
freeVars (MatchCase Pattern loc
_ Maybe (Term f a a)
g Term f a a
rhs) =
      let guardVars :: Set a
guardVars = Set a -> (Term f a a -> Set a) -> Maybe (Term f a a) -> Set a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set a
forall a. Set a
Set.empty Term f a a -> Set a
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Maybe (Term f a a)
g
          rhsVars :: Set a
rhsVars = Term f a a -> Set a
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term f a a
rhs
       in Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
guardVars Set a
rhsVars

pattern Bytes' :: [Word64] -> Term3 v PrintAnnotation
pattern $mBytes' :: forall {r} {v}.
Term3 v PrintAnnotation -> ([Word64] -> r) -> ((# #) -> r) -> r
Bytes' bs <- (toBytes -> Just bs)

toBytes :: Term3 v PrintAnnotation -> Maybe [Word64]
toBytes :: forall v. Term3 v PrintAnnotation -> Maybe [Word64]
toBytes (App' (Builtin' Text
"Bytes.fromList") (List' Seq (Term (F v () ()) v PrintAnnotation)
bs)) =
  Seq Word64 -> [Word64]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Word64 -> [Word64]) -> Maybe (Seq Word64) -> Maybe [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term (F v () ()) v PrintAnnotation -> Maybe Word64)
-> Seq (Term (F v () ()) v PrintAnnotation) -> Maybe (Seq Word64)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seq a -> f (Seq b)
traverse Term (F v () ()) v PrintAnnotation -> Maybe Word64
forall {typeVar} {typeAnn} {patternAnn} {v} {a}.
Term (F typeVar typeAnn patternAnn) v a -> Maybe Word64
go Seq (Term (F v () ()) v PrintAnnotation)
bs
  where
    go :: Term (F typeVar typeAnn patternAnn) v a -> Maybe Word64
go (Nat' Word64
n) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
    go Term (F typeVar typeAnn patternAnn) v a
_ = Maybe Word64
forall a. Maybe a
Nothing
toBytes Term (F v () ()) v PrintAnnotation
_ = Maybe [Word64]
forall a. Maybe a
Nothing

prettyDoc2 ::
  forall v m.
  (MonadPretty v m) =>
  AmbientContext ->
  Term3 v PrintAnnotation ->
  m (Maybe (Pretty SyntaxText))
prettyDoc2 :: forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext
-> Term3 v PrintAnnotation -> m (Maybe (Pretty SyntaxText))
prettyDoc2 AmbientContext
ac Term3 v PrintAnnotation
tm = do
  Env v
env <- m (Env v)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let brace :: Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
brace Pretty (SyntaxText' r)
p =
        if Pretty (SyntaxText' r) -> Bool
forall s. Pretty s -> Bool
PP.isMultiLine Pretty (SyntaxText' r)
p
          then Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter Pretty (SyntaxText' r)
"{{" Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
forall s. IsString s => Pretty s
PP.newline Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
p Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
forall s. IsString s => Pretty s
PP.newline Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter Pretty (SyntaxText' r)
"}}"
          else Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter Pretty (SyntaxText' r)
"{{" Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
forall s. IsString s => Pretty s
PP.softbreak Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
p Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Pretty (SyntaxText' r)
forall s. IsString s => Pretty s
PP.softbreak Pretty (SyntaxText' r)
-> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall a. Semigroup a => a -> a -> a
<> Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt Element r
forall r. Element r
S.DocDelimiter Pretty (SyntaxText' r)
"}}"
      bail :: Term3 v PrintAnnotation -> m (Pretty SyntaxText)
bail Term3 v PrintAnnotation
tm = Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
brace (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ac Term3 v PrintAnnotation
tm
      contains :: Char -> Pretty SyntaxText -> Bool
      contains :: Char -> Pretty SyntaxText -> Bool
contains Char
c Pretty SyntaxText
p =
        Pretty ColorText -> String
PP.toPlainUnbroken (Pretty SyntaxText -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor Pretty SyntaxText
p)
          String -> (String -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c
      -- Finds the longest run of a character and return one bigger than that
      longestRun :: Char -> Pretty (SyntaxText' r) -> Int
longestRun Char
c Pretty (SyntaxText' r)
s =
        case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
s -> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2 String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== [Char
c, Char
c]) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
          String -> [String]
forall a. Eq a => [a] -> [[a]]
List.group (Pretty ColorText -> String
PP.toPlainUnbroken (Pretty ColorText -> String) -> Pretty ColorText -> String
forall a b. (a -> b) -> a -> b
$ Pretty (SyntaxText' r) -> Pretty ColorText
forall r. Pretty (SyntaxText' r) -> Pretty ColorText
PP.syntaxToColor Pretty (SyntaxText' r)
s) of
          [] -> Int
2
          [String]
x -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
x)
      oneMore :: Char -> Pretty (SyntaxText' r) -> String
oneMore Char
c Pretty (SyntaxText' r)
inner = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Char -> Pretty (SyntaxText' r) -> Int
forall {r}. Char -> Pretty (SyntaxText' r) -> Int
longestRun Char
c Pretty (SyntaxText' r)
inner) Char
c
      makeFence :: Pretty (SyntaxText' r) -> Pretty s
makeFence Pretty (SyntaxText' r)
inner = String -> Pretty s
forall s. IsString s => String -> Pretty s
PP.string (String -> Pretty s) -> String -> Pretty s
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
3 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Char -> Pretty (SyntaxText' r) -> Int
forall {r}. Char -> Pretty (SyntaxText' r) -> Int
longestRun Char
'`' Pretty (SyntaxText' r)
inner) Char
'`'
      go :: Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
      go :: Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Width
hdr = \case
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocTransclude Env v
env.ppe -> Just Term3 v PrintAnnotation
d) ->
          Term3 v PrintAnnotation -> m (Pretty SyntaxText)
bail Term3 v PrintAnnotation
d
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocUntitledSection Env v
env.ppe -> Just [Term3 v PrintAnnotation]
ds) ->
          [Term3 v PrintAnnotation] -> m (Pretty SyntaxText)
sepBlankline [Term3 v PrintAnnotation]
ds
        (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
toDocSection Env v
env.ppe -> Just (Term3 v PrintAnnotation
title, [Term3 v PrintAnnotation]
ds)) -> do
          Pretty SyntaxText
prettyTitle <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
title
          Pretty SyntaxText
prettyDs <- Pretty SyntaxText
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation]
-> m (Pretty SyntaxText)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m, Monoid a) =>
a -> (b -> m a) -> t b -> m a
intercalateMapM Pretty SyntaxText
"\n\n" (Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go (Width
hdr Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
1)) [Term3 v PrintAnnotation]
ds
          pure $
            [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
              [ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text (Int -> Text -> Text
Text.replicate (Width -> Int
PP.widthToInt Width
hdr) Text
"#") Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
prettyTitle,
                Pretty SyntaxText
"",
                Width -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
PP.indentN (Width
hdr Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
1) Pretty SyntaxText
prettyDs
              ]
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocParagraph Env v
env.ppe -> Just [Term3 v PrintAnnotation]
ds) ->
          Pretty SyntaxText -> Pretty SyntaxText
forall s. (ListLike s Char, IsString s) => Pretty s -> Pretty s
PP.wrap (Pretty SyntaxText -> Pretty SyntaxText)
-> ([Pretty SyntaxText] -> Pretty SyntaxText)
-> [Pretty SyntaxText]
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pretty SyntaxText] -> Pretty SyntaxText
forall m. Monoid m => [m] -> m
mconcat ([Pretty SyntaxText] -> Pretty SyntaxText)
-> m [Pretty SyntaxText] -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec [Term3 v PrintAnnotation]
ds
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocBulletedList Env v
env.ppe -> Just [Term3 v PrintAnnotation]
ds) -> do
          [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText] -> Pretty SyntaxText)
-> m [Pretty SyntaxText] -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term3 v PrintAnnotation -> m (Pretty SyntaxText)
item [Term3 v PrintAnnotation]
ds
          where
            item :: Term3 v PrintAnnotation -> m (Pretty SyntaxText)
item Term3 v PrintAnnotation
d = (Pretty SyntaxText
"* " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<>) (Pretty SyntaxText -> Pretty SyntaxText)
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
PP.indentAfterNewline Pretty SyntaxText
"  " (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
        (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Word64, [Term3 v PrintAnnotation])
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Word64, [Term3 v PrintAnnotation])
toDocNumberedList Env v
env.ppe -> Just (Word64
n, [Term3 v PrintAnnotation]
ds)) ->
          [(Pretty SyntaxText, Pretty SyntaxText)] -> Pretty SyntaxText
forall s.
(ListLike s Char, IsString s) =>
[(Pretty s, Pretty s)] -> Pretty s
PP.column2 ([(Pretty SyntaxText, Pretty SyntaxText)] -> Pretty SyntaxText)
-> m [(Pretty SyntaxText, Pretty SyntaxText)]
-> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Word64, Term3 v PrintAnnotation)
 -> m (Pretty SyntaxText, Pretty SyntaxText))
-> [(Word64, Term3 v PrintAnnotation)]
-> m [(Pretty SyntaxText, Pretty SyntaxText)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Word64, Term3 v PrintAnnotation)
-> m (Pretty SyntaxText, Pretty SyntaxText)
item ([Word64]
-> [Term3 v PrintAnnotation] -> [(Word64, Term3 v PrintAnnotation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64
n ..] [Term3 v PrintAnnotation]
ds)
          where
            item :: (Word64, Term3 v PrintAnnotation)
-> m (Pretty SyntaxText, Pretty SyntaxText)
item (Word64
n, Term3 v PrintAnnotation
d) = (Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Word64 -> Pretty SyntaxText
forall a s. (Show a, IsString s) => a -> Pretty s
PP.shown Word64
n Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"."),) (Pretty SyntaxText -> (Pretty SyntaxText, Pretty SyntaxText))
-> m (Pretty SyntaxText)
-> m (Pretty SyntaxText, Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
        (PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
forall v. PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocWord Env v
env.ppe -> Just Text
t) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
t
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocCode Env v
env.ppe -> Just Term3 v PrintAnnotation
d) -> do
          Pretty SyntaxText
inner <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
          let quotes :: Pretty SyntaxText
quotes =
                -- Prefer ` if there aren't any in the inner text,
                -- otherwise use one more than the longest run of ' in the inner text
                if Char -> Pretty SyntaxText -> Bool
contains Char
'`' Pretty SyntaxText
inner
                  then String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
PP.string (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Char -> Pretty SyntaxText -> String
forall {r}. Char -> Pretty (SyntaxText' r) -> String
oneMore Char
'\'' Pretty SyntaxText
inner
                  else String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
PP.string String
"`"
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
quotes Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
quotes
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocJoin Env v
env.ppe -> Just [Term3 v PrintAnnotation]
ds) -> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m (Pretty SyntaxText)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec [Term3 v PrintAnnotation]
ds
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocItalic Env v
env.ppe -> Just Term3 v PrintAnnotation
d) -> do
          Pretty SyntaxText
inner <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
          let underscores :: Pretty SyntaxText
underscores = String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
PP.string (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Char -> Pretty SyntaxText -> String
forall {r}. Char -> Pretty (SyntaxText' r) -> String
oneMore Char
'_' Pretty SyntaxText
inner
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
underscores Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
underscores
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocBold Env v
env.ppe -> Just Term3 v PrintAnnotation
d) -> do
          Pretty SyntaxText
inner <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
          let stars :: Pretty SyntaxText
stars = String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
PP.string (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Char -> Pretty SyntaxText -> String
forall {r}. Char -> Pretty (SyntaxText' r) -> String
oneMore Char
'*' Pretty SyntaxText
inner
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
stars Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
stars
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocStrikethrough Env v
env.ppe -> Just Term3 v PrintAnnotation
d) -> do
          Pretty SyntaxText
inner <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
          let quotes :: Pretty SyntaxText
quotes = String -> Pretty SyntaxText
forall s. IsString s => String -> Pretty s
PP.string (String -> Pretty SyntaxText) -> String -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Char -> Pretty SyntaxText -> String
forall {r}. Char -> Pretty (SyntaxText' r) -> String
oneMore Char
'~' Pretty SyntaxText
inner
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
quotes Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
quotes
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocGroup Env v
env.ppe -> Just Term3 v PrintAnnotation
d) ->
          Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> m (Pretty SyntaxText) -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
d
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocColumn Env v
env.ppe -> Just [Term3 v PrintAnnotation]
ds) ->
          [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines ([Pretty SyntaxText] -> Pretty SyntaxText)
-> m [Pretty SyntaxText] -> m (Pretty SyntaxText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation] -> m [Pretty SyntaxText]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec [Term3 v PrintAnnotation]
ds
        (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
toDocNamedLink Env v
env.ppe -> Just (Term3 v PrintAnnotation
name, Term3 v PrintAnnotation
target)) ->
          do
            Pretty SyntaxText
name' <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
name
            Pretty SyntaxText
target' <- Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec Term3 v PrintAnnotation
target
            pure $ Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"[" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
name' Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"](" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
target' Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
")"
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
toDocLink Env v
env.ppe -> Just Either Reference Referent
e) -> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ case Either Reference Referent
e of
          Left Reference
r -> Pretty SyntaxText
"{type " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Reference -> Pretty SyntaxText
tyName Reference
r Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
          Right Referent
r -> Pretty SyntaxText
"{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
tmName Referent
r Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEval Env v
env.ppe -> Just Term3 v PrintAnnotation
tm) ->
          do
            Pretty SyntaxText
inner <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ac Term3 v PrintAnnotation
tm
            let fence :: Pretty SyntaxText
fence = Pretty SyntaxText -> Pretty SyntaxText
forall {s} {r}. IsString s => Pretty (SyntaxText' r) -> Pretty s
makeFence Pretty SyntaxText
inner
            Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines [Pretty SyntaxText
fence, Pretty SyntaxText
inner, Pretty SyntaxText
fence]
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEvalInline Env v
env.ppe -> Just Term3 v PrintAnnotation
tm) ->
          do
            Pretty SyntaxText
inner <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ac Term3 v PrintAnnotation
tm
            pure $ Pretty SyntaxText
"@eval{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExample Env v
env.ppe -> Just Term3 v PrintAnnotation
tm) ->
          do
            Pretty SyntaxText
inner <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ac Term3 v PrintAnnotation
tm
            pure $ Pretty SyntaxText
"``" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
inner Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"``"
        (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExampleBlock Env v
env.ppe -> Just Term3 v PrintAnnotation
tm) ->
          do
            Pretty SyntaxText
inner <- AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
forall v (m :: * -> *).
MonadPretty v m =>
AmbientContext -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
pretty0 AmbientContext
ac' Term3 v PrintAnnotation
tm
            let fence :: Pretty SyntaxText
fence = Pretty SyntaxText -> Pretty SyntaxText
forall {s} {r}. IsString s => Pretty (SyntaxText' r) -> Pretty s
makeFence Pretty SyntaxText
inner
            Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines [Pretty SyntaxText
"@typecheck " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
fence, Pretty SyntaxText
inner, Pretty SyntaxText
fence]
          where
            ac' :: AmbientContext
ac' = AmbientContext
ac {elideUnit = True}
        (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocSource Env v
env.ppe -> Just [(Either Reference Referent, [Referent])]
es) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"    @source{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
-> ((Either Reference Referent, [Referent]) -> Pretty SyntaxText)
-> [(Either Reference Referent, [Referent])]
-> Pretty SyntaxText
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap Pretty SyntaxText
", " (Either Reference Referent, [Referent]) -> Pretty SyntaxText
go [(Either Reference Referent, [Referent])]
es Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
          where
            go :: (Either Reference Referent, [Referent]) -> Pretty SyntaxText
go (Left Reference
r, [Referent]
_anns) = Pretty SyntaxText
"type " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Reference -> Pretty SyntaxText
tyName Reference
r
            go (Right Referent
r, [Referent]
_anns) = Referent -> Pretty SyntaxText
tmName Referent
r
        (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocFoldedSource Env v
env.ppe -> Just [(Either Reference Referent, [Referent])]
es) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"    @foldedSource{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
-> ((Either Reference Referent, [Referent]) -> Pretty SyntaxText)
-> [(Either Reference Referent, [Referent])]
-> Pretty SyntaxText
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap Pretty SyntaxText
", " (Either Reference Referent, [Referent]) -> Pretty SyntaxText
go [(Either Reference Referent, [Referent])]
es Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
          where
            go :: (Either Reference Referent, [Referent]) -> Pretty SyntaxText
go (Left Reference
r, [Referent]
_anns) = Pretty SyntaxText
"type " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Reference -> Pretty SyntaxText
tyName Reference
r
            go (Right Referent
r, [Referent]
_anns) = Referent -> Pretty SyntaxText
tmName Referent
r
        (PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocSignatureInline Env v
env.ppe -> Just Referent
tm) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"@inlineSignature{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Referent -> Pretty SyntaxText
tmName Referent
tm Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
        (PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSignature Env v
env.ppe -> Just [Referent]
tms) ->
          let name :: Pretty SyntaxText
name = if [Referent] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Referent]
tms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Pretty SyntaxText
"@signature" else Pretty SyntaxText
"@signatures"
           in Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> m (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$ Pretty SyntaxText
"    " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
name Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"{" Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
-> (Referent -> Pretty SyntaxText)
-> [Referent]
-> Pretty SyntaxText
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap Pretty SyntaxText
", " Referent -> Pretty SyntaxText
tmName [Referent]
tms Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
"}"
        (PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Text, Text)
forall v.
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Text, Text)
toDocCodeBlock Env v
env.ppe -> Just (Text
typ, Text
txt)) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
            let txt' :: Pretty SyntaxText
txt' = Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
txt
                fence :: Pretty SyntaxText
fence = Pretty SyntaxText -> Pretty SyntaxText
forall {s} {r}. IsString s => Pretty (SyntaxText' r) -> Pretty s
makeFence Pretty SyntaxText
txt'
             in Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
                  [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                    [ Pretty SyntaxText
fence Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Pretty SyntaxText
" " Pretty SyntaxText -> Pretty SyntaxText -> Pretty SyntaxText
forall a. Semigroup a => a -> a -> a
<> Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
typ,
                      Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group Pretty SyntaxText
txt',
                      Pretty SyntaxText
fence
                    ]
        (PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
forall v. PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocVerbatim Env v
env.ppe -> Just Text
txt) ->
          Pretty SyntaxText -> m (Pretty SyntaxText)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pretty SyntaxText -> m (Pretty SyntaxText))
-> Pretty SyntaxText -> m (Pretty SyntaxText)
forall a b. (a -> b) -> a -> b
$
            Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$
              [Pretty SyntaxText] -> Pretty SyntaxText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
PP.lines
                [ Pretty SyntaxText
"'''",
                  Pretty SyntaxText -> Pretty SyntaxText
forall s. Pretty s -> Pretty s
PP.group (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Text -> Pretty SyntaxText
forall s. IsString s => Text -> Pretty s
PP.text Text
txt,
                  Pretty SyntaxText
"'''"
                ]
        -- todo : emit fewer gratuitous columns, maybe a wrapIfMany combinator
        Term3 v PrintAnnotation
tm -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
bail Term3 v PrintAnnotation
tm
        where
          im :: Imports
im = AmbientContext -> Imports
imports AmbientContext
ac
          tyName :: Reference -> Pretty SyntaxText
tyName Reference
r = (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Reference -> Element Reference
forall r. r -> Element r
S.TypeReference Reference
r) (HashQualified Name -> Pretty SyntaxText)
-> (HashQualified Name -> HashQualified Name)
-> HashQualified Name
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Reference -> HashQualified Name
PrettyPrintEnv.typeName Env v
env.ppe Reference
r
          tmName :: Referent -> Pretty SyntaxText
tmName Referent
r = (Pretty SyntaxText -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
styleHashQualified'' (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall r.
Element r -> Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
fmt (Element Reference -> Pretty SyntaxText -> Pretty SyntaxText)
-> Element Reference -> Pretty SyntaxText -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ Referent -> Element Reference
forall r. Referent' r -> Element r
S.TermReference Referent
r) (HashQualified Name -> Pretty SyntaxText)
-> (HashQualified Name -> HashQualified Name)
-> HashQualified Name
-> Pretty SyntaxText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Imports -> HashQualified Name -> HashQualified Name
elideFQN Imports
im (HashQualified Name -> Pretty SyntaxText)
-> HashQualified Name -> Pretty SyntaxText
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName Env v
env.ppe Referent
r
          rec :: Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec = Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Width
hdr
          sepBlankline :: [Term3 v PrintAnnotation] -> m (Pretty SyntaxText)
sepBlankline = Pretty SyntaxText
-> (Term3 v PrintAnnotation -> m (Pretty SyntaxText))
-> [Term3 v PrintAnnotation]
-> m (Pretty SyntaxText)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m, Monoid a) =>
a -> (b -> m a) -> t b -> m a
intercalateMapM Pretty SyntaxText
"\n\n" Term3 v PrintAnnotation -> m (Pretty SyntaxText)
rec
  case Term3 v PrintAnnotation
tm of
    -- these patterns can introduce a {{ .. }} block
    (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocUntitledSection Env v
env.ppe -> Just [Term3 v PrintAnnotation]
_) -> Pretty SyntaxText -> Maybe (Pretty SyntaxText)
forall a. a -> Maybe a
Just (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> Maybe (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
brace (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> m (Pretty SyntaxText) -> m (Maybe (Pretty SyntaxText))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Width
1 Term3 v PrintAnnotation
tm
    (PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
toDocSection Env v
env.ppe -> Just (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
_) -> Pretty SyntaxText -> Maybe (Pretty SyntaxText)
forall a. a -> Maybe a
Just (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> Maybe (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
brace (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> m (Pretty SyntaxText) -> m (Maybe (Pretty SyntaxText))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Width
1 Term3 v PrintAnnotation
tm
    (PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocParagraph Env v
env.ppe -> Just [Term3 v PrintAnnotation]
_) -> Pretty SyntaxText -> Maybe (Pretty SyntaxText)
forall a. a -> Maybe a
Just (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> (Pretty SyntaxText -> Pretty SyntaxText)
-> Pretty SyntaxText
-> Maybe (Pretty SyntaxText)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pretty SyntaxText -> Pretty SyntaxText
forall {r}. Pretty (SyntaxText' r) -> Pretty (SyntaxText' r)
brace (Pretty SyntaxText -> Maybe (Pretty SyntaxText))
-> m (Pretty SyntaxText) -> m (Maybe (Pretty SyntaxText))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Width -> Term3 v PrintAnnotation -> m (Pretty SyntaxText)
go Width
1 Term3 v PrintAnnotation
tm
    Term3 v PrintAnnotation
_ -> Maybe (Pretty SyntaxText) -> m (Maybe (Pretty SyntaxText))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Pretty SyntaxText)
forall a. Maybe a
Nothing

toDocJoin :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocJoin :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocJoin PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docJoin" Reference
r = [Term (F v () ()) v PrintAnnotation]
-> Maybe [Term (F v () ()) v PrintAnnotation]
forall a. a -> Maybe a
Just (Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms)
toDocJoin PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Term (F v () ()) v PrintAnnotation]
forall a. Maybe a
Nothing

toDocUntitledSection :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocUntitledSection :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocUntitledSection PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docUntitledSection" Reference
r = [Term (F v () ()) v PrintAnnotation]
-> Maybe [Term (F v () ()) v PrintAnnotation]
forall a. a -> Maybe a
Just (Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms)
toDocUntitledSection PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Term (F v () ()) v PrintAnnotation]
forall a. Maybe a
Nothing

toDocColumn :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocColumn :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocColumn PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docColumn" Reference
r = [Term (F v () ()) v PrintAnnotation]
-> Maybe [Term (F v () ()) v PrintAnnotation]
forall a. a -> Maybe a
Just (Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms)
toDocColumn PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Term (F v () ()) v PrintAnnotation]
forall a. Maybe a
Nothing

toDocGroup :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocGroup :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocGroup PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
doc)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docGroup" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
doc
toDocGroup PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocWord :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocWord :: forall v. PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocWord PrettyPrintEnv
ppe (App' (Ref' Reference
r) (Text' Text
txt))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docWord" Reference
r = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt
toDocWord PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Text
forall a. Maybe a
Nothing

toDocBold :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocBold :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocBold PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
doc)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docBold" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
doc
toDocBold PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocCode :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocCode :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocCode PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
doc)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docCode" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
doc
toDocCode PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocCodeBlock :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Text, Text)
toDocCodeBlock :: forall v.
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Text, Text)
toDocCodeBlock PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Text' Text
typ, Text' Text
txt])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docCodeBlock" Reference
r = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
typ, Text
txt)
toDocCodeBlock PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe (Text, Text)
forall a. Maybe a
Nothing

toDocVerbatim :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocVerbatim :: forall v. PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocVerbatim PrettyPrintEnv
ppe (App' (Ref' Reference
r) (PrettyPrintEnv -> Term (F v () ()) v PrintAnnotation -> Maybe Text
forall v. PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Text
toDocWord PrettyPrintEnv
ppe -> Just Text
txt))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docVerbatim" Reference
r = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt
toDocVerbatim PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Text
forall a. Maybe a
Nothing

toDocEval :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEval :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEval PrettyPrintEnv
ppe (App' (Ref' Reference
r) (DDelay' Term (F v () ()) v PrintAnnotation
tm))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docEval" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
tm
  | Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
_oldDocEval = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
tm
toDocEval PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

-- Old hashes for docEval, docEvalInline w/ incorrect type signatures.
-- They are still used by some existing docs so the pretty-printer
-- recognizes it.
--
-- See https://github.com/unisonweb/unison/issues/2238
_oldDocEval, _oldDocEvalInline :: Reference
_oldDocEval :: Reference
_oldDocEval = Text -> Reference
Reference.unsafeFromText Text
"#m2bmkdos2669tt46sh2gf6cmb4td5le8lcqnmsl9nfaqiv7s816q8bdtjdbt98tkk11ejlesepe7p7u8p0asu9758gdseffh0t78m2o"
_oldDocEvalInline :: Reference
_oldDocEvalInline = Text -> Reference
Reference.unsafeFromText Text
"#7pjlvdu42gmfvfntja265dmi08afk08l54kpsuu55l9hq4l32fco2jlrm8mf2jbn61esfsi972b6e66d9on4i5bkmfchjdare1v5npg"

-- for docs, we consider a delay to be any function that ignores its arg
pattern DDelay' :: (Var v) => Term2 vt at ap v a -> Term2 vt at ap v a
pattern $mDDelay' :: forall {r} {v} {vt} {at} {ap} {a}.
Var v =>
Term2 vt at ap v a
-> (Term2 vt at ap v a -> r) -> ((# #) -> r) -> r
DDelay' body <- (unDDelay -> Just body)

unDDelay :: (Var v) => Term2 vt at ap v a -> Maybe (Term2 vt at ap v a)
unDDelay :: forall v vt at ap a.
Var v =>
Term2 vt at ap v a -> Maybe (Term2 vt at ap v a)
unDDelay Term2 vt at ap v a
tm = case Term2 vt at ap v a -> ABT (F vt at ap) v (Term2 vt at ap v a)
forall (f :: * -> *) v a. Term f v a -> ABT f v (Term f v a)
ABT.out Term2 vt at ap v a
tm of
  ABT.Tm (Lam (ABT.Term Set v
_ a
_ (ABT.Abs v
v Term2 vt at ap v a
body)))
    | v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember v
v (Term2 vt at ap v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term2 vt at ap v a
body) -> Term2 vt at ap v a -> Maybe (Term2 vt at ap v a)
forall a. a -> Maybe a
Just Term2 vt at ap v a
body
  ABT (F vt at ap) v (Term2 vt at ap v a)
_ -> Maybe (Term2 vt at ap v a)
forall a. Maybe a
Nothing

toDocEvalInline :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEvalInline :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocEvalInline PrettyPrintEnv
ppe (App' (Ref' Reference
r) (DDelay' Term (F v () ()) v PrintAnnotation
tm))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docEvalInline" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
tm
  | Reference
r Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
_oldDocEvalInline = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
tm
toDocEvalInline PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocExample, toDocExampleBlock :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExample :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExample = Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation)
toDocExample' Text
".docExample"
toDocExampleBlock :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExampleBlock = Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation)
forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation)
toDocExample' Text
".docExampleBlock"

toDocExample' :: (Var v) => Text -> PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocExample' :: forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation)
toDocExample' Text
suffix PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Nat' Word64
n, l :: Term2 v () () v PrintAnnotation
l@(LamsNamed' [v]
vs Term2 v () () v PrintAnnotation
tm)])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
suffix Reference
r,
    Term2 v () () v PrintAnnotation -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term2 v () () v PrintAnnotation
l Set v -> Set v -> Bool
forall a. Eq a => a -> a -> Bool
== Set v
forall a. Monoid a => a
mempty,
    Term2 v () () v PrintAnnotation -> Bool
forall {v} {vt} {at} {ap} {a}. Ord v => Term2 vt at ap v a -> Bool
ok Term2 v () () v PrintAnnotation
tm =
      Term2 v () () v PrintAnnotation
-> Maybe (Term2 v () () v PrintAnnotation)
forall a. a -> Maybe a
Just (PrintAnnotation
-> [v]
-> Term2 v () () v PrintAnnotation
-> Term2 v () () v PrintAnnotation
forall v a vt at ap.
Ord v =>
a -> [v] -> Term2 vt at ap v a -> Term2 vt at ap v a
lamWithoutBindingAnns (Term2 v () () v PrintAnnotation -> PrintAnnotation
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term2 v () () v PrintAnnotation
l) (Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [v]
vs) Term2 v () () v PrintAnnotation
tm)
  where
    ok :: Term2 vt at ap v a -> Bool
ok (Apps' Term2 vt at ap v a
f [Term2 vt at ap v a]
_) = Term2 vt at ap v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term2 vt at ap v a
f Set v -> Set v -> Bool
forall a. Eq a => a -> a -> Bool
== Set v
forall a. Monoid a => a
mempty
    ok Term2 vt at ap v a
tm = Term2 vt at ap v a -> Set v
forall (f :: * -> *) v a. Term f v a -> Set v
ABT.freeVars Term2 vt at ap v a
tm Set v -> Set v -> Bool
forall a. Eq a => a -> a -> Bool
== Set v
forall a. Monoid a => a
mempty
toDocExample' Text
_ PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe (Term2 v () () v PrintAnnotation)
forall a. Maybe a
Nothing

toDocTransclude :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocTransclude :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocTransclude PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
tm)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docTransclude" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
tm
toDocTransclude PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocLink :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
toDocLink :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
toDocLink PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
tm)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docLink" Reference
r = case Term (F v () ()) v PrintAnnotation
tm of
      (PrettyPrintEnv
-> Term (F v () ()) v PrintAnnotation -> Maybe Referent
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedTermLink PrettyPrintEnv
ppe -> Just Referent
tm) -> Either Reference Referent -> Maybe (Either Reference Referent)
forall a. a -> Maybe a
Just (Referent -> Either Reference Referent
forall a b. b -> Either a b
Right Referent
tm)
      (PrettyPrintEnv
-> Term (F v () ()) v PrintAnnotation -> Maybe Reference
forall v.
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Reference
toDocEmbedTypeLink PrettyPrintEnv
ppe -> Just Reference
tm) -> Either Reference Referent -> Maybe (Either Reference Referent)
forall a. a -> Maybe a
Just (Reference -> Either Reference Referent
forall a b. a -> Either a b
Left Reference
tm)
      Term (F v () ()) v PrintAnnotation
_ -> Maybe (Either Reference Referent)
forall a. Maybe a
Nothing
toDocLink PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Either Reference Referent)
forall a. Maybe a
Nothing

toDocNamedLink :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
toDocNamedLink :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
toDocNamedLink PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Term2 v () () v PrintAnnotation
name, Term2 v () () v PrintAnnotation
target])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docNamedLink" Reference
r = (Term2 v () () v PrintAnnotation, Term2 v () () v PrintAnnotation)
-> Maybe
     (Term2 v () () v PrintAnnotation, Term2 v () () v PrintAnnotation)
forall a. a -> Maybe a
Just (Term2 v () () v PrintAnnotation
name, Term2 v () () v PrintAnnotation
target)
toDocNamedLink PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe
  (Term2 v () () v PrintAnnotation, Term2 v () () v PrintAnnotation)
forall a. Maybe a
Nothing

toDocItalic :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocItalic :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocItalic PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
doc)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docItalic" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
doc
toDocItalic PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocStrikethrough :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocStrikethrough :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
toDocStrikethrough PrettyPrintEnv
ppe (App' (Ref' Reference
r) Term (F v () ()) v PrintAnnotation
doc)
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docStrikethrough" Reference
r = Term (F v () ()) v PrintAnnotation
-> Maybe (Term (F v () ()) v PrintAnnotation)
forall a. a -> Maybe a
Just Term (F v () ()) v PrintAnnotation
doc
toDocStrikethrough PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe (Term (F v () ()) v PrintAnnotation)
forall a. Maybe a
Nothing

toDocParagraph :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocParagraph :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocParagraph PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docParagraph" Reference
r = [Term (F v () ()) v PrintAnnotation]
-> Maybe [Term (F v () ()) v PrintAnnotation]
forall a. a -> Maybe a
Just (Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms)
toDocParagraph PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Term (F v () ()) v PrintAnnotation]
forall a. Maybe a
Nothing

toDocEmbedTermLink :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedTermLink :: forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedTermLink PrettyPrintEnv
ppe (App' (Ref' Reference
r) (DDelay' (Referent' Referent
tm)))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docEmbedTermLink" Reference
r = Referent -> Maybe Referent
forall a. a -> Maybe a
Just Referent
tm
toDocEmbedTermLink PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Referent
forall a. Maybe a
Nothing

toDocEmbedTypeLink :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Reference
toDocEmbedTypeLink :: forall v.
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Reference
toDocEmbedTypeLink PrettyPrintEnv
ppe (App' (Ref' Reference
r) (TypeLink' Reference
typeref))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docEmbedTypeLink" Reference
r = Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
typeref
toDocEmbedTypeLink PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Reference
forall a. Maybe a
Nothing

toDocSourceAnnotations :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSourceAnnotations :: forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSourceAnnotations PrettyPrintEnv
_ppe Term3 v PrintAnnotation
_tm = [Referent] -> Maybe [Referent]
forall a. a -> Maybe a
Just [] -- todo fetch annotations

toDocSourceElement :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent, [Referent])
toDocSourceElement :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Either Reference Referent, [Referent])
toDocSourceElement PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Term2 v () () v PrintAnnotation
tm, PrettyPrintEnv
-> Term2 v () () v PrintAnnotation -> Maybe [Referent]
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSourceAnnotations PrettyPrintEnv
ppe -> Just [Referent]
annotations])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docSourceElement" Reference
r =
      (,[Referent]
annotations) (Either Reference Referent
 -> (Either Reference Referent, [Referent]))
-> Maybe (Either Reference Referent)
-> Maybe (Either Reference Referent, [Referent])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term2 v () () v PrintAnnotation
-> Maybe (Either Reference Referent)
ok Term2 v () () v PrintAnnotation
tm
  where
    ok :: Term2 v () () v PrintAnnotation
-> Maybe (Either Reference Referent)
ok Term2 v () () v PrintAnnotation
tm =
      Referent -> Either Reference Referent
forall a b. b -> Either a b
Right (Referent -> Either Reference Referent)
-> Maybe Referent -> Maybe (Either Reference Referent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrettyPrintEnv -> Term2 v () () v PrintAnnotation -> Maybe Referent
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedTermLink PrettyPrintEnv
ppe Term2 v () () v PrintAnnotation
tm
        Maybe (Either Reference Referent)
-> Maybe (Either Reference Referent)
-> Maybe (Either Reference Referent)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Reference -> Either Reference Referent
forall a b. a -> Either a b
Left (Reference -> Either Reference Referent)
-> Maybe Reference -> Maybe (Either Reference Referent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrettyPrintEnv
-> Term2 v () () v PrintAnnotation -> Maybe Reference
forall v.
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Reference
toDocEmbedTypeLink PrettyPrintEnv
ppe Term2 v () () v PrintAnnotation
tm
toDocSourceElement PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe (Either Reference Referent, [Referent])
forall a. Maybe a
Nothing

toDocSource' ::
  (Var v) =>
  Text ->
  PrettyPrintEnv ->
  Term3 v PrintAnnotation ->
  Maybe [(Either Reference Referent, [Referent])]
toDocSource' :: forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocSource' Text
suffix PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
suffix Reference
r =
      case [(Either Reference Referent, [Referent])
tm | Just (Either Reference Referent, [Referent])
tm <- PrettyPrintEnv
-> Term (F v () ()) v PrintAnnotation
-> Maybe (Either Reference Referent, [Referent])
forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Either Reference Referent, [Referent])
toDocSourceElement PrettyPrintEnv
ppe (Term (F v () ()) v PrintAnnotation
 -> Maybe (Either Reference Referent, [Referent]))
-> [Term (F v () ()) v PrintAnnotation]
-> [Maybe (Either Reference Referent, [Referent])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms] of
        [(Either Reference Referent, [Referent])]
tms' | [(Either Reference Referent, [Referent])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Either Reference Referent, [Referent])]
tms' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq (Term (F v () ()) v PrintAnnotation) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Term (F v () ()) v PrintAnnotation)
tms -> [(Either Reference Referent, [Referent])]
-> Maybe [(Either Reference Referent, [Referent])]
forall a. a -> Maybe a
Just [(Either Reference Referent, [Referent])]
tms'
        [(Either Reference Referent, [Referent])]
_ -> Maybe [(Either Reference Referent, [Referent])]
forall a. Maybe a
Nothing
toDocSource' Text
_ PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [(Either Reference Referent, [Referent])]
forall a. Maybe a
Nothing

toDocSource,
  toDocFoldedSource ::
    (Var v) =>
    PrettyPrintEnv ->
    Term3 v PrintAnnotation ->
    Maybe [(Either Reference Referent, [Referent])]
toDocSource :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocSource = Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocSource' Text
".docSource"
toDocFoldedSource :: forall v.
Var v =>
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocFoldedSource = Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
forall v.
Var v =>
Text
-> PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe [(Either Reference Referent, [Referent])]
toDocSource' Text
".docFoldedSource"

toDocSignatureInline :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocSignatureInline :: forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocSignatureInline PrettyPrintEnv
ppe (App' (Ref' Reference
r) (PrettyPrintEnv
-> Term (F v () ()) v PrintAnnotation -> Maybe Referent
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedSignatureLink PrettyPrintEnv
ppe -> Just Referent
tm))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docSignatureInline" Reference
r = Referent -> Maybe Referent
forall a. a -> Maybe a
Just Referent
tm
toDocSignatureInline PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Referent
forall a. Maybe a
Nothing

toDocEmbedSignatureLink :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedSignatureLink :: forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedSignatureLink PrettyPrintEnv
ppe (App' (Ref' Reference
r) (DDelay' (Referent' Referent
tm)))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docEmbedSignatureLink" Reference
r = Referent -> Maybe Referent
forall a. a -> Maybe a
Just Referent
tm
toDocEmbedSignatureLink PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe Referent
forall a. Maybe a
Nothing

-- toDocEmbedAnnotation :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation)
-- toDocEmbedAnnotation ppe (App' (Ref' r) tm)
--   | nameEndsWith ppe ".docEmbedAnnotation" r = Just tm
-- toDocEmbedAnnotation _ _ = Nothing

-- toDocEmbedAnnotations :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
-- toDocEmbedAnnotations ppe (App' (Ref' r) (List' tms))
--   | nameEndsWith ppe ".docEmbedAnnotations" r =
--     case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
--       tms' | length tms' == length tms -> Just tms'
--       _ -> Nothing
-- toDocEmbedAnnotations _ _ = Nothing

toDocSignature :: (Var v) => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSignature :: forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSignature PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docSignature" Reference
r =
      case [Referent
tm | Just Referent
tm <- PrettyPrintEnv
-> Term (F v () ()) v PrintAnnotation -> Maybe Referent
forall v.
Var v =>
PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe Referent
toDocEmbedSignatureLink PrettyPrintEnv
ppe (Term (F v () ()) v PrintAnnotation -> Maybe Referent)
-> [Term (F v () ()) v PrintAnnotation] -> [Maybe Referent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms] of
        [Referent]
tms' | [Referent] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Referent]
tms' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq (Term (F v () ()) v PrintAnnotation) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (Term (F v () ()) v PrintAnnotation)
tms -> [Referent] -> Maybe [Referent]
forall a. a -> Maybe a
Just [Referent]
tms'
        [Referent]
_ -> Maybe [Referent]
forall a. Maybe a
Nothing
toDocSignature PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Referent]
forall a. Maybe a
Nothing

toDocBulletedList :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocBulletedList :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocBulletedList PrettyPrintEnv
ppe (App' (Ref' Reference
r) (List' Seq (Term (F v () ()) v PrintAnnotation)
tms))
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docBulletedList" Reference
r = [Term (F v () ()) v PrintAnnotation]
-> Maybe [Term (F v () ()) v PrintAnnotation]
forall a. a -> Maybe a
Just (Seq (Term (F v () ()) v PrintAnnotation)
-> [Term (F v () ()) v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term (F v () ()) v PrintAnnotation)
tms)
toDocBulletedList PrettyPrintEnv
_ Term (F v () ()) v PrintAnnotation
_ = Maybe [Term (F v () ()) v PrintAnnotation]
forall a. Maybe a
Nothing

toDocNumberedList ::
  PrettyPrintEnv ->
  Term3 v PrintAnnotation ->
  Maybe (Word64, [Term3 v PrintAnnotation])
toDocNumberedList :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Word64, [Term3 v PrintAnnotation])
toDocNumberedList PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Nat' Word64
n, List' Seq (Term2 v () () v PrintAnnotation)
tms])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docNumberedList" Reference
r = (Word64, [Term2 v () () v PrintAnnotation])
-> Maybe (Word64, [Term2 v () () v PrintAnnotation])
forall a. a -> Maybe a
Just (Word64
n, Seq (Term2 v () () v PrintAnnotation)
-> [Term2 v () () v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term2 v () () v PrintAnnotation)
tms)
toDocNumberedList PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe (Word64, [Term2 v () () v PrintAnnotation])
forall a. Maybe a
Nothing

toDocSection ::
  PrettyPrintEnv ->
  Term3 v PrintAnnotation ->
  Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
toDocSection :: forall v.
PrettyPrintEnv
-> Term3 v PrintAnnotation
-> Maybe (Term3 v PrintAnnotation, [Term3 v PrintAnnotation])
toDocSection PrettyPrintEnv
ppe (Apps' (Ref' Reference
r) [Term2 v () () v PrintAnnotation
title, List' Seq (Term2 v () () v PrintAnnotation)
tms])
  | PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
".docSection" Reference
r = (Term2 v () () v PrintAnnotation,
 [Term2 v () () v PrintAnnotation])
-> Maybe
     (Term2 v () () v PrintAnnotation,
      [Term2 v () () v PrintAnnotation])
forall a. a -> Maybe a
Just (Term2 v () () v PrintAnnotation
title, Seq (Term2 v () () v PrintAnnotation)
-> [Term2 v () () v PrintAnnotation]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term2 v () () v PrintAnnotation)
tms)
toDocSection PrettyPrintEnv
_ Term2 v () () v PrintAnnotation
_ = Maybe
  (Term2 v () () v PrintAnnotation,
   [Term2 v () () v PrintAnnotation])
forall a. Maybe a
Nothing

nameEndsWith :: PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith :: PrettyPrintEnv -> Text -> Reference -> Bool
nameEndsWith PrettyPrintEnv
ppe Text
suffix Reference
r = case PrettyPrintEnv -> Referent -> HashQualified Name
PrettyPrintEnv.termName PrettyPrintEnv
ppe (Reference -> Referent
Referent.Ref Reference
r) of
  HQ.NameOnly Name
n ->
    let tn :: Text
tn = Name -> Text
Name.toText Name
n
     in Text
tn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Text -> Text
Text.drop Int
1 Text
suffix Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isSuffixOf Text
suffix Text
tn
  HashQualified Name
_ -> Bool
False

-- Modifies a PrettyPrintEnv to avoid picking a name for a term or type ref
-- which is the same as a locally introduced variable. For example:
--
--   qux.quaffle = 23
--
--   example : Text -> Nat
--   example quaffle = qux.quaffle + 1
--
-- Here, we want the pretty-printer to use the name 'qux.quaffle' even though
-- 'quaffle' would otherwise be a unique suffix.
--
-- Algorithm is the following:
--   1. Form the set of all local variables used anywhere in the term
--   2. When picking a name for a term, see if it is contained in this set.
--      If yes: use a minimally qualified name which is longer than the suffixed name,
--              but doesn't conflict with any local vars. If even the fully-qualified
--              name conflicts with any local vars, make it absolute. (This relies on
--              disallowing absolute names for local variables).
--      If no: use the suffixed name for the term
--
-- The algorithm does the same for type references in signatures.
--
-- This algorithm is conservative in the sense that it doesn't take into account
-- the binding structure of the term. If the variable 'quaffle' is used as a local
-- variable anywhere in the term, then 'quaffle' will not be considered a unique suffix
-- even in places where the local 'quaffle' isn't in scope.
--
-- To do better this, you'd have to track bound variables in the pretty-printer and
-- fold this logic into the core pretty-printing implementation. This conservative
-- algorithm has the advantage of being purely a preprocessing step.
avoidShadowing :: (Var v, Var vt) => Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing :: forall v vt at ap a.
(Var v, Var vt) =>
Term2 vt at ap v a -> PrettyPrintEnv -> PrettyPrintEnv
avoidShadowing Term2 vt at ap v a
tm (PrettyPrintEnv Referent -> [(HashQualified Name, HashQualified Name)]
terms Reference -> [(HashQualified Name, HashQualified Name)]
types) =
  (Referent -> [(HashQualified Name, HashQualified Name)])
-> (Reference -> [(HashQualified Name, HashQualified Name)])
-> PrettyPrintEnv
PrettyPrintEnv Referent -> [(HashQualified Name, HashQualified Name)]
terms' Reference -> [(HashQualified Name, HashQualified Name)]
types'
  where
    terms' :: Referent -> [(HashQualified Name, HashQualified Name)]
terms' Referent
r = Set Name
-> (HashQualified Name, HashQualified Name)
-> (HashQualified Name, HashQualified Name)
tweak Set Name
usedTermNames ((HashQualified Name, HashQualified Name)
 -> (HashQualified Name, HashQualified Name))
-> [(HashQualified Name, HashQualified Name)]
-> [(HashQualified Name, HashQualified Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Referent -> [(HashQualified Name, HashQualified Name)]
terms Referent
r
    types' :: Reference -> [(HashQualified Name, HashQualified Name)]
types' Reference
r = Set Name
-> (HashQualified Name, HashQualified Name)
-> (HashQualified Name, HashQualified Name)
tweak Set Name
usedTypeNames ((HashQualified Name, HashQualified Name)
 -> (HashQualified Name, HashQualified Name))
-> [(HashQualified Name, HashQualified Name)]
-> [(HashQualified Name, HashQualified Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reference -> [(HashQualified Name, HashQualified Name)]
types Reference
r
    usedTermNames :: Set Name
usedTermNames =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | v
v <- Term2 vt at ap v a -> [v]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Term2 vt at ap v a
tm, Name
n <- v -> [Name]
forall v. Var v => v -> [Name]
varToName v
v]
    usedTypeNames :: Set Name
usedTypeNames =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | Ann' Term2 vt at ap v a
_ Type vt at
ty <- Term2 vt at ap v a -> [Term2 vt at ap v a]
forall v (f :: * -> *) a.
(Ord v, Traversable f) =>
Term f v a -> [Term f v a]
ABT.subterms Term2 vt at ap v a
tm, vt
v <- Type vt at -> [vt]
forall (f :: * -> *) v a. Foldable f => Term f v a -> [v]
ABT.allVars Type vt at
ty, Name
n <- vt -> [Name]
forall v. Var v => v -> [Name]
varToName vt
v]
    tweak :: Set Name -> (HQ'.HashQualified Name, HQ'.HashQualified Name) -> (HQ'.HashQualified Name, HQ'.HashQualified Name)
    tweak :: Set Name
-> (HashQualified Name, HashQualified Name)
-> (HashQualified Name, HashQualified Name)
tweak Set Name
used (HQ'.NameOnly Name
fullName, HQ'.NameOnly Name
suffixedName)
      | Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
suffixedName Set Name
used =
          let resuffixifiedName :: Name
              resuffixifiedName :: Name
resuffixifiedName =
                Name
fullName
                  Name -> (Name -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Name -> [Name]
Name.suffixes
                  -- Drop the suffixes that we know are shorter than the suffixified name
                  [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
List.drop (Name -> Int
Name.countSegments Name
suffixedName)
                  -- Find the first (shortest) suffix that isn't in the used set
                  [Name] -> ([Name] -> Maybe Name) -> Maybe Name
forall a b. a -> (a -> b) -> b
& (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Name
n -> Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
used)
                  -- If there isn't one, use the absolut-ified full name
                  Maybe Name -> (Maybe Name -> Name) -> Name
forall a b. a -> (a -> b) -> b
& Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (Name -> Name
Name.makeAbsolute Name
fullName)
           in (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.NameOnly Name
fullName, Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.NameOnly Name
resuffixifiedName)
    tweak Set Name
_ (HashQualified Name, HashQualified Name)
p = (HashQualified Name, HashQualified Name)
p
    varToName :: (Var v) => v -> [Name]
    varToName :: forall v. Var v => v -> [Name]
varToName = Maybe Name -> [Name]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Name -> [Name]) -> (v -> Maybe Name) -> v -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Name
Name.parseText (Text -> Maybe Name) -> (v -> Text) -> v -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name (v -> Text) -> (v -> v) -> v -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> v
forall v. Var v => v -> v
Var.reset

isLeaf :: Term2 vt at ap v a -> Bool
isLeaf :: forall vt at ap v a. Term2 vt at ap v a -> Bool
isLeaf (Var' {}) = Bool
True
isLeaf (Constructor' {}) = Bool
True
isLeaf (Request' {}) = Bool
True
isLeaf (Ref' {}) = Bool
True
isLeaf Term (F vt at ap) v a
_ = Bool
False