{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, OverloadedStrings, ScopedTypeVariables,
             TypeApplications, TypeFamilies, UndecidableInstances #-}

-- | This module exports the instances of the 'Pretty' type class necessary for printing of a Modula-2 abstract syntax
-- tree.

module Language.Modula2.Pretty () where

import Control.Applicative (ZipList(ZipList, getZipList))
import Data.Functor.Identity (Identity(..))
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty((:|)), fromList, toList)
import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import Numeric (showHex, showOct)

import qualified Language.Oberon.Abstract
import qualified Language.Oberon.AST
import qualified Language.Modula2.Abstract as Abstract
import Language.Modula2.AST
import Language.Oberon.Pretty (Precedence(Precedence))
import qualified Language.Oberon.AST as Oberon

instance (Pretty (Abstract.Priority l l Identity Identity),
          Pretty (Abstract.Export l),
          Pretty (Abstract.Import l),
          Pretty (Abstract.Declaration l l Identity Identity),
          Pretty (Abstract.Definition l l Identity Identity),
          Pretty (Abstract.Block l l Identity Identity)) =>
         Pretty (Module λ l Identity Identity) where
   pretty :: forall ann. Module λ l Identity Identity -> Doc ann
pretty (DefinitionModule Ident
name [Import l]
imports Maybe (Export l)
export ZipList (Identity (Definition l l Identity Identity))
declarations) =
      forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      [Doc ann
"DEFINITION" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"MODULE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi,
       forall ann. [Doc ann] -> Doc ann
vsep (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports),
       forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Export l)
export]
      forall a. Semigroup a => a -> a -> a
<> (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (Definition l l Identity Identity))
declarations)
      forall a. Semigroup a => a -> a -> a
<> [Doc ann
"END" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line]
   pretty (ImplementationModule Ident
name Maybe (Identity (Priority l l Identity Identity))
priority [Import l]
imports Identity (Block l l Identity Identity)
body) =
     Doc ann
"IMPLEMENTATION" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall λ l (f' :: * -> *) (f :: * -> *).
Ident
-> Maybe (f (Priority l l f' f'))
-> [Import l]
-> f (Block l l f' f')
-> Module λ l f' f
ProgramModule Ident
name Maybe (Identity (Priority l l Identity Identity))
priority [Import l]
imports Identity (Block l l Identity Identity)
body)
   pretty (ProgramModule Ident
name Maybe (Identity (Priority l l Identity Identity))
priority [Import l]
imports Identity (Block l l Identity Identity)
body) =
      forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      [Doc ann
"MODULE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall ann. Doc ann -> Doc ann
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) Maybe (Identity (Priority l l Identity Identity))
priority forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi,
       forall ann. [Doc ann] -> Doc ann
vsep (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports)]
      forall a. Semigroup a => a -> a -> a
<> [forall ann. [Doc ann] -> Doc ann
vsep [forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body, Doc ann
"END" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line]]

instance Pretty (Abstract.IdentDef l) => Pretty (Import l) where
  pretty :: forall ann. Import l -> Doc ann
pretty (Import Maybe Ident
origin NonEmpty Ident
names) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann
"FROM" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) Maybe Ident
origin (Doc ann
"IMPORT" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Ident
names))
    forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi

instance Pretty (Abstract.IdentDef l) => Pretty (Export l) where
  pretty :: forall ann. Export l -> Doc ann
pretty (Export Bool
qualified NonEmpty Ident
names) =
    Doc ann
"EXPORT" forall ann. Doc ann -> Doc ann -> Doc ann
<+> (if Bool
qualified then (Doc ann
"QUALIFIED" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) else forall a. a -> a
id) (forall ann. [Doc ann] -> Doc ann
hsep forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Ident
names)
    forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi

instance Pretty (IdentDef l) where
  pretty :: forall ann. IdentDef l -> Doc ann
pretty (IdentDef Ident
name) = forall a ann. Pretty a => a -> Doc ann
pretty Ident
name

instance (Abstract.Nameable l, Pretty (Abstract.IdentDef l),
          Pretty (Abstract.Export l), Pretty (Abstract.Import l),
          Pretty (Abstract.Type l l Identity Identity),
          Pretty (Abstract.Declaration l l Identity Identity),
          Pretty (Abstract.Expression l l Identity Identity),
          Pretty (Abstract.FormalParameters l l Identity Identity),
          Pretty (Abstract.ProcedureHeading l l Identity Identity),
          Pretty (Abstract.Block l l Identity Identity)) =>
         Pretty (Declaration False Language l Identity Identity) where
   pretty :: forall ann.
Declaration 'False Language l Identity Identity -> Doc ann
pretty (ProcedureDefinition Identity (ProcedureHeading l l Identity Identity)
heading) = forall a ann. Pretty a => a -> Doc ann
pretty Identity (ProcedureHeading l l Identity Identity)
heading forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi
   pretty (ConstantDeclaration IdentDef l
ident (Identity Expression l l Identity Identity
expr)) = Doc ann
"CONST" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Expression l l Identity Identity
expr forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi
   pretty (TypeDeclaration IdentDef l
ident Identity (Type l l Identity Identity)
typeDef) = Doc ann
"TYPE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
typeDef forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi
   pretty (OpaqueTypeDeclaration IdentDef l
ident) = Doc ann
"TYPE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi
   pretty (VariableDeclaration IdentList l
idents Identity (Type l l Identity Identity)
varType) =
      Doc ann
"VAR" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
toList IdentList l
idents) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
colon forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
varType forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi

instance (Abstract.Nameable l, Pretty (Abstract.IdentDef l),
          Pretty (Abstract.Export l), Pretty (Abstract.Import l),
          Pretty (Abstract.Type l l Identity Identity),
          Pretty (Abstract.Declaration l l Identity Identity),
          Pretty (Abstract.Expression l l Identity Identity),
          Pretty (Abstract.FormalParameters l l Identity Identity),
          Pretty (Abstract.ProcedureHeading l l Identity Identity),
          Pretty (Abstract.Block l l Identity Identity)) =>
         Pretty (Declaration True Language l Identity Identity) where
   pretty :: forall ann.
Declaration 'True Language l Identity Identity -> Doc ann
pretty (ProcedureDeclaration Identity (ProcedureHeading l l Identity Identity)
heading Identity (Block l l Identity Identity)
body) = forall ann. [Doc ann] -> Doc ann
vsep [forall a ann. Pretty a => a -> Doc ann
pretty Identity (ProcedureHeading l l Identity Identity)
heading forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi,
                                                      forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body,
                                                      Doc ann
"END" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' (f' :: * -> *) (f :: * -> *).
(Nameable l, Nameable l') =>
ProcedureHeading l l' f' f -> Ident
Abstract.getProcedureName forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity Identity (ProcedureHeading l l Identity Identity)
heading)
                                                      forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi]
   pretty (ModuleDeclaration Ident
name Maybe (Identity (Expression l l Identity Identity))
priority [Import l]
imports Maybe (Export l)
export Identity (Block l l Identity Identity)
body) =
      forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
      [Doc ann
"MODULE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall ann. Doc ann -> Doc ann
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) Maybe (Identity (Expression l l Identity Identity))
priority forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi,
       forall ann. [Doc ann] -> Doc ann
vsep (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports),
       forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Export l)
export,
       forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body,
       Doc ann
"END" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
semi]
   pretty Declaration 'True Language l Identity Identity
declaration = forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Declaration l l'' f' f -> Declaration l' l'' f' f
Abstract.coDeclaration
                                                       @Language @(Abstract.WirthySubsetOf Oberon.Language) Declaration 'True Language l Identity Identity
declaration)

instance (Pretty (Precedence (Abstract.Expression l l Identity Identity)),
          Pretty (Abstract.Value l l Identity Identity),
          Pretty (Abstract.Expression l l Identity Identity),
          Pretty (Abstract.Element l l Identity Identity),
          Pretty (Abstract.Designator l l Identity Identity),
          Pretty (Abstract.QualIdent l)) => Pretty (Expression Language l Identity Identity) where
   pretty :: forall ann. Expression Language l Identity Identity -> Doc ann
pretty Expression Language l Identity Identity
e = forall a ann. Pretty a => a -> Doc ann
pretty (forall e. Int -> e -> Precedence e
Precedence Int
0 Expression Language l Identity Identity
e)

instance (Pretty (Precedence (Abstract.Expression l l Identity Identity)),
          Pretty (Abstract.Value l l Identity Identity),
          Pretty (Abstract.Expression l l Identity Identity),
          Pretty (Abstract.Element l l Identity Identity),
          Pretty (Abstract.Designator l l Identity Identity),
          Pretty (Abstract.QualIdent l)) =>
         Pretty (Precedence (Expression Language l Identity Identity)) where
   pretty :: forall ann.
Precedence (Expression Language l Identity Identity) -> Doc ann
pretty (Precedence Int
_ (Set Maybe (QualIdent l)
ty ZipList (Identity (Element l l Identity Identity))
elements)) =
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a ann. Pretty a => a -> Doc ann
pretty Maybe (QualIdent l)
ty forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
braces (forall ann. [Doc ann] -> Doc ann
hsep forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (Element l l Identity Identity))
elements)
   pretty (Precedence Int
p Expression Language l Identity Identity
e) =
      forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Int -> e -> Precedence e
Precedence Int
p) (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Expression l l'' f' f -> Expression l' l'' f' f
Abstract.coExpression @Language @(Abstract.WirthySubsetOf Oberon.Language) Expression Language l Identity Identity
e)

instance Pretty (Abstract.Value l l Identity Identity) => Pretty (Value Language l Identity Identity) where
   pretty :: forall ann. Value Language l Identity Identity -> Doc ann
pretty (CharCode Int
c) = forall a ann. Pretty a => a -> Doc ann
pretty (forall a. (Integral a, Show a) => a -> ShowS
showOct Int
c String
"") forall a. Semigroup a => a -> a -> a
<> Doc ann
"C"
   pretty Value Language l Identity Identity
v = forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Value l l'' f' f -> Value l' l'' f' f
Abstract.coValue @Language @(Abstract.WirthySubsetOf Oberon.Language) Value Language l Identity Identity
v)

instance (Pretty (Abstract.QualIdent l), Pretty (Abstract.Designator l l Identity Identity),
          Pretty (Abstract.Expression l l Identity Identity)) => Pretty (Designator Language l Identity Identity) where
   pretty :: forall ann. Designator Language l Identity Identity -> Doc ann
pretty Designator Language l Identity Identity
d = forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Designator l l'' f' f -> Designator l' l'' f' f
Abstract.coDesignator @Language @(Abstract.WirthySubsetOf Oberon.Language) Designator Language l Identity Identity
d)

instance (Pretty (Abstract.IdentDef l), Pretty (Abstract.FormalParameters l l Identity Identity),
          Pretty (Abstract.FieldList l l Identity Identity),
          Pretty (Abstract.ConstExpression l l Identity Identity), Pretty (Abstract.Type l l Identity Identity),
          Pretty (Abstract.BaseType l)) => Pretty (Type Language l Identity Identity) where
   pretty :: forall ann. Type Language l Identity Identity -> Doc ann
pretty (ArrayType ZipList (Identity (Type l l Identity Identity))
dimensions Identity (Type l l Identity Identity)
itemType) =
      Doc ann
"ARRAY" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (Type l l Identity Identity))
dimensions) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
itemType
   pretty (EnumerationType IdentList l
values) = Doc ann
"(" forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentList l
values) forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
   pretty (SubrangeType Maybe (BaseType l)
enumType Identity (ConstExpression l l Identity Identity)
min Identity (ConstExpression l l Identity Identity)
max) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a ann. Pretty a => a -> Doc ann
pretty Maybe (BaseType l)
enumType forall a. Semigroup a => a -> a -> a
<> Doc ann
"[" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
min forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
".." forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
max forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
   pretty (SetType Identity (Type l l Identity Identity)
memberType) = Doc ann
"SET" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
memberType
   pretty (RecordType ZipList (Identity (FieldList l l Identity Identity))
fields) = forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"RECORD",
                                       forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
semi forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (FieldList l l Identity Identity))
fields),
                                       Doc ann
"END"]
   pretty (ProcedureType Maybe (Identity (FormalParameters l l Identity Identity))
parameters) = Doc ann
"PROCEDURE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall {ann1} {ann}. Doc ann1 -> Doc ann
adjust (forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Identity (FormalParameters l l Identity Identity))
parameters)
      where adjust :: Doc ann1 -> Doc ann
adjust = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Ident -> Ident -> Ident
Text.replace Ident
" : " Ident
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Ident -> Ident -> Ident
Text.replace Ident
";" Ident
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. SimpleDocStream ann -> Ident
renderStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact
   pretty Type Language l Identity Identity
ty = forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Type l l'' f' f -> Type l' l'' f' f
Abstract.coType @Language @(Abstract.WirthySubsetOf Oberon.Language) Type Language l Identity Identity
ty)

instance Pretty (QualIdent l) where
   pretty :: forall ann. QualIdent l -> Doc ann
pretty (QualIdent [Ident]
modulePath Ident
name) = forall a. Monoid a => [a] -> a
mconcat (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
dot forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Ident]
modulePath forall a. Semigroup a => a -> a -> a
<> [Ident
name]))

instance (Pretty (Abstract.IdentDef l), Pretty (Abstract.QualIdent l), Pretty (Abstract.Type l l Identity Identity),
          Pretty (Abstract.Value l l Identity Identity),
          Pretty (Abstract.FieldList l l Identity Identity), Pretty (Abstract.Variant l l Identity Identity)) =>
         Pretty (FieldList Language l Identity Identity) where
   pretty :: forall ann. FieldList Language l Identity Identity -> Doc ann
pretty (CaseFieldList Maybe Ident
localName QualIdent l
name Identity (Variant l l Identity Identity)
variant ZipList (Identity (Variant l l Identity Identity))
variants ZipList (Identity (FieldList l l Identity Identity))
fallback) =
     forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann
"CASE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) Maybe Ident
localName (forall a ann. Pretty a => a -> Doc ann
pretty QualIdent l
name) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF"]
           forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate' Doc ann
"| " (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identity (Variant l l Identity Identity)
variant forall a. a -> [a] -> [a]
: forall a. ZipList a -> [a]
getZipList ZipList (Identity (Variant l l Identity Identity))
variants))
           forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null ZipList (Identity (FieldList l l Identity Identity))
fallback then []
               else [Doc ann
"ELSE" forall ann. Doc ann -> Doc ann -> Doc ann
<#>
                     forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
semi forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (FieldList l l Identity Identity))
fallback)])
           forall a. Semigroup a => a -> a -> a
<> [Doc ann
"END"])
   pretty (FieldList IdentList l
names Identity (Type l l Identity Identity)
t) = forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
toList IdentList l
names) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
t

instance (Pretty (Abstract.CaseLabels l l Identity Identity), Pretty (Abstract.FieldList l l Identity Identity)) =>
         Pretty (Variant λ l Identity Identity) where
  pretty :: forall ann. Variant λ l Identity Identity -> Doc ann
pretty (Variant Identity (CaseLabels l l Identity Identity)
label ZipList (Identity (CaseLabels l l Identity Identity))
labels ZipList (Identity (FieldList l l Identity Identity))
fields) = forall ann. [Doc ann] -> Doc ann
vsep [forall ann. [Doc ann] -> Doc ann
hsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identity (CaseLabels l l Identity Identity)
label forall a. a -> [a] -> [a]
: forall a. ZipList a -> [a]
getZipList ZipList (Identity (CaseLabels l l Identity Identity))
labels)) forall a. Semigroup a => a -> a -> a
<> Doc ann
":",
                                               forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
semi forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ZipList a -> [a]
getZipList ZipList (Identity (FieldList l l Identity Identity))
fields)]

instance (Pretty (Abstract.IdentDef l), Pretty (Abstract.FormalParameters l l Identity Identity),
          Pretty (Abstract.Type l l Identity Identity)) =>
         Pretty (ProcedureHeading l l Identity Identity) where
   pretty :: forall ann. ProcedureHeading l l Identity Identity -> Doc ann
pretty (ProcedureHeading Ident
name Maybe (Identity (FormalParameters l l Identity Identity))
parameters) =
      Doc ann
"PROCEDURE" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
name forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Identity (FormalParameters l l Identity Identity))
parameters

instance (Pretty (Abstract.ConstExpression l l Identity Identity),
          Pretty (Abstract.Designator l l Identity Identity),
          Pretty (Abstract.Case l l Identity Identity),
          Pretty (Abstract.ConditionalBranch l l Identity Identity),
          Pretty (Language.Oberon.Abstract.WithAlternative l l Identity Identity),
          Pretty (Abstract.StatementSequence l l Identity Identity)) =>
         Pretty (Statement Language l Identity Identity) where
   prettyList :: forall ann. [Statement Language l Identity Identity] -> Doc ann
prettyList [Statement Language l Identity Identity]
l = forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> [Doc ann]
dropEmptyTail forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
semi forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Statement Language l Identity Identity]
l)
      where dropEmptyTail :: [Doc ann] -> [Doc ann]
dropEmptyTail
               | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Statement Language l Identity Identity]
l), Statement Language l Identity Identity
EmptyStatement <- forall a. [a] -> a
last [Statement Language l Identity Identity]
l = forall a. [a] -> [a]
init
               | Bool
otherwise = forall a. a -> a
id
   pretty :: forall ann. Statement Language l Identity Identity -> Doc ann
pretty (For Ident
index Identity (ConstExpression l l Identity Identity)
from Identity (ConstExpression l l Identity Identity)
to Maybe (Identity (ConstExpression l l Identity Identity))
by Identity (StatementSequence l l Identity Identity)
body) = forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"FOR" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Ident
index forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
from forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"TO" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
to
                                              forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Doc ann
"BY" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (forall a ann. Pretty a => a -> Doc ann
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Identity (ConstExpression l l Identity Identity))
by) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"DO",
                                              forall l ann.
Pretty (StatementSequence l l Identity Identity) =>
Identity (StatementSequence l l Identity Identity) -> Doc ann
prettyBody Identity (StatementSequence l l Identity Identity)
body,
                                              Doc ann
"END"]
   pretty (With Identity (Designator l l Identity Identity)
designator Identity (StatementSequence l l Identity Identity)
body) = forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"WITH" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Identity (Designator l l Identity Identity)
designator forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"DO",
                                         forall l ann.
Pretty (StatementSequence l l Identity Identity) =>
Identity (StatementSequence l l Identity Identity) -> Doc ann
prettyBody Identity (StatementSequence l l Identity Identity)
body,
                                         Doc ann
"END"]
   pretty Statement Language l Identity Identity
stat = forall {k1} {k2} {k3} {b1} {f :: k1 -> k2 -> k3 -> *} {a :: k1}
       {b2 :: k2} {c :: k3}.
b1 -> (f a b2 c -> b1) -> Maybe3 f a b2 c -> b1
Abstract.maybe3 forall a. Monoid a => a
mempty forall a ann. Pretty a => a -> Doc ann
pretty (forall l l' l'' (f' :: * -> *) (f :: * -> *).
(CoWirthy l, TargetClass l l') =>
Statement l l'' f' f -> Statement l' l'' f' f
Abstract.coStatement @Language @(Abstract.WirthySubsetOf Oberon.Language) Statement Language l Identity Identity
stat)

instance Language.Oberon.Abstract.Oberon Language where
   type WithAlternative Language = Language.Oberon.AST.WithAlternative Language
--instance Pretty (Language.Oberon.AST.WithAlternative Language Language Identity Identity) where
--   pretty _ = error "There's no WithAlternative in Modula-2."

prettyBody :: Pretty (Abstract.StatementSequence l l Identity Identity) =>
              Identity (Abstract.StatementSequence l l Identity Identity) -> Doc ann
prettyBody :: forall l ann.
Pretty (StatementSequence l l Identity Identity) =>
Identity (StatementSequence l l Identity Identity) -> Doc ann
prettyBody (Identity StatementSequence l l Identity Identity
statements) = forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (forall a ann. Pretty a => a -> Doc ann
pretty StatementSequence l l Identity Identity
statements)

punctuate' :: Doc ann -> [Doc ann] -> [Doc ann]
punctuate' :: forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate' Doc ann
p [] = []
punctuate' Doc ann
p (Doc ann
x:[Doc ann]
xs) = Doc ann
x forall a. a -> [a] -> [a]
: ((Doc ann
p forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc ann]
xs)

Doc ann
a <#> :: Doc ann -> Doc ann -> Doc ann
<#> Doc ann
b = forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
a, Doc ann
b]