{-# 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 :: 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) =
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse Doc ann
forall a. Monoid a => a
mempty ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
      [Doc ann
"DEFINITION" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"MODULE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi,
       [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Import l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Import l -> Doc ann) -> [Import l] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports),
       (Export l -> Doc ann) -> Maybe (Export l) -> Doc ann
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Export l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Export l)
export]
      [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (Identity (Definition l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (Definition l l Identity Identity) -> Doc ann)
-> [Identity (Definition l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (Definition l l Identity Identity))
-> [Identity (Definition l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (Definition l l Identity Identity))
declarations)
      [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann
"END" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line]
   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" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Module Any l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Ident
-> Maybe (Identity (Priority l l Identity Identity))
-> [Import l]
-> Identity (Block l l Identity Identity)
-> Module Any l Identity Identity
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) =
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse Doc ann
forall a. Monoid a => a
mempty ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
      [Doc ann
"MODULE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
-> (Identity (Priority l l Identity Identity) -> Doc ann)
-> Maybe (Identity (Priority l l Identity Identity))
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall a. Monoid a => a
mempty (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann)
-> (Identity (Priority l l Identity Identity) -> Doc ann)
-> Identity (Priority l l Identity Identity)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Priority l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) Maybe (Identity (Priority l l Identity Identity))
priority Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi,
       [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Import l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Import l -> Doc ann) -> [Import l] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports)]
      [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Identity (Block l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body, Doc ann
"END" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line]]

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

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

instance Pretty (IdentDef l) where
  pretty :: IdentDef l -> Doc ann
pretty (IdentDef Ident
name) = Ident -> Doc ann
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 :: Declaration 'False Language l Identity Identity -> Doc ann
pretty (ProcedureDefinition Identity (ProcedureHeading l l Identity Identity)
heading) = Identity (ProcedureHeading l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ProcedureHeading l l Identity Identity)
heading Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
   pretty (ConstantDeclaration IdentDef l
ident (Identity Expression l l Identity Identity
expr)) = Doc ann
"CONST" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Expression l l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Expression l l Identity Identity
expr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
   pretty (TypeDeclaration IdentDef l
ident Identity (Type l l Identity Identity)
typeDef) = Doc ann
"TYPE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Type l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
typeDef Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
   pretty (OpaqueTypeDeclaration IdentDef l
ident) = Doc ann
"TYPE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IdentDef l
ident Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
   pretty (VariableDeclaration IdentList l
idents Identity (Type l l Identity Identity)
varType) =
      Doc ann
"VAR" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (IdentDef l -> Doc ann) -> [IdentDef l] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentList l -> [IdentDef l]
forall a. NonEmpty a -> [a]
toList IdentList l
idents) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Type l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Type l l Identity Identity)
varType Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
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 :: Declaration 'True Language l Identity Identity -> Doc ann
pretty (ProcedureDeclaration Identity (ProcedureHeading l l Identity Identity)
heading Identity (Block l l Identity Identity)
body) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Identity (ProcedureHeading l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ProcedureHeading l l Identity Identity)
heading Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi,
                                                      Identity (Block l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body,
                                                      Doc ann
"END" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ProcedureHeading l l Identity Identity -> Ident
forall l l' (f' :: * -> *) (f :: * -> *).
(Nameable l, Nameable l') =>
ProcedureHeading l l' f' f -> Ident
Abstract.getProcedureName (ProcedureHeading l l Identity Identity -> Ident)
-> ProcedureHeading l l Identity Identity -> Ident
forall a b. (a -> b) -> a -> b
$ Identity (ProcedureHeading l l Identity Identity)
-> ProcedureHeading l l Identity Identity
forall a. Identity a -> a
runIdentity Identity (ProcedureHeading l l Identity Identity)
heading)
                                                      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
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) =
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse Doc ann
forall a. Monoid a => a
mempty ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
      [Doc ann
"MODULE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
-> (Identity (Expression l l Identity Identity) -> Doc ann)
-> Maybe (Identity (Expression l l Identity Identity))
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall a. Monoid a => a
mempty (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann)
-> (Identity (Expression l l Identity Identity) -> Doc ann)
-> Identity (Expression l l Identity Identity)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Expression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) Maybe (Identity (Expression l l Identity Identity))
priority Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi,
       [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Import l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Import l -> Doc ann) -> [Import l] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import l]
imports),
       (Export l -> Doc ann) -> Maybe (Export l) -> Doc ann
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Export l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Export l)
export,
       Identity (Block l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Block l l Identity Identity)
body,
       Doc ann
"END" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi]
   pretty Declaration 'True Language l Identity Identity
declaration = Doc ann
-> (Declaration Language l Identity Identity -> Doc ann)
-> Maybe3 (Declaration Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty Declaration Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Declaration Language l Identity Identity
-> Declaration (WirthySubsetOf Language) l Identity Identity
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 Language l Identity Identity
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 :: Expression Language l Identity Identity -> Doc ann
pretty Expression Language l Identity Identity
e = Precedence (Expression Language l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int
-> Expression Language l Identity Identity
-> Precedence (Expression Language l Identity Identity)
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 :: Precedence (Expression Language l Identity Identity) -> Doc ann
pretty (Precedence Int
_ (Set Maybe (QualIdent l)
ty ZipList (Identity (Element l l Identity Identity))
elements)) =
      (QualIdent l -> Doc ann) -> Maybe (QualIdent l) -> Doc ann
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap QualIdent l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe (QualIdent l)
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Identity (Element l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (Element l l Identity Identity) -> Doc ann)
-> [Identity (Element l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (Element l l Identity Identity))
-> [Identity (Element l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (Element l l Identity Identity))
elements)
   pretty (Precedence Int
p Expression Language l Identity Identity
e) =
      Doc ann
-> (Expression Language l Identity Identity -> Doc ann)
-> Maybe3 (Expression Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty (Precedence (Expression Language l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Precedence (Expression Language l Identity Identity) -> Doc ann)
-> (Expression Language l Identity Identity
    -> Precedence (Expression Language l Identity Identity))
-> Expression Language l Identity Identity
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Expression Language l Identity Identity
-> Precedence (Expression Language l Identity Identity)
forall e. Int -> e -> Precedence e
Precedence Int
p) (Expression Language l Identity Identity
-> Expression (WirthySubsetOf Language) l Identity Identity
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
Expression Language l Identity Identity
e)

instance Pretty (Abstract.Value l l Identity Identity) => Pretty (Value Language l Identity Identity) where
   pretty :: Value Language l Identity Identity -> Doc ann
pretty (CharCode Int
c) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showOct Int
c String
"") Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"C"
   pretty Value Language l Identity Identity
v = Doc ann
-> (Value Language l Identity Identity -> Doc ann)
-> Maybe3 (Value Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty Value Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Value Language l Identity Identity
-> Value (WirthySubsetOf Language) l Identity Identity
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
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 :: Designator Language l Identity Identity -> Doc ann
pretty Designator Language l Identity Identity
d = Doc ann
-> (Designator Language l Identity Identity -> Doc ann)
-> Maybe3 (Designator Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty Designator Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Designator Language l Identity Identity
-> Designator (WirthySubsetOf Language) l Identity Identity
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
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 :: 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" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Type l l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type l l Identity Identity -> Doc ann)
-> (Identity (Type l l Identity Identity)
    -> Type l l Identity Identity)
-> Identity (Type l l Identity Identity)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Type l l Identity Identity) -> Type l l Identity Identity
forall a. Identity a -> a
runIdentity (Identity (Type l l Identity Identity) -> Doc ann)
-> [Identity (Type l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (Type l l Identity Identity))
-> [Identity (Type l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (Type l l Identity Identity))
dimensions) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Type l l Identity Identity) -> 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
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Doc ann) -> [Doc ann]
forall a. NonEmpty a -> [a]
toList (NonEmpty (Doc ann) -> [Doc ann])
-> NonEmpty (Doc ann) -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (IdentDef l -> Doc ann) -> IdentList l -> NonEmpty (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentList l
values) Doc ann -> Doc ann -> Doc ann
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) = (BaseType l -> Doc ann) -> Maybe (BaseType l) -> Doc ann
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BaseType l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe (BaseType l)
enumType Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Identity (ConstExpression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
min Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
".." Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (ConstExpression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
max Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
   pretty (SetType Identity (Type l l Identity Identity)
memberType) = Doc ann
"SET" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Type l l Identity Identity) -> 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) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"RECORD",
                                       Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
semi ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Identity (FieldList l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (FieldList l l Identity Identity) -> Doc ann)
-> [Identity (FieldList l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (FieldList l l Identity Identity))
-> [Identity (FieldList l l Identity Identity)]
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" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any -> Doc ann
forall ann ann. Doc ann -> Doc ann
adjust (Maybe (Identity (FormalParameters l l Identity Identity))
-> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Maybe (Identity (FormalParameters l l Identity Identity))
parameters)
      where adjust :: Doc ann -> Doc ann
adjust = Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Ident -> Doc ann) -> (Doc ann -> Ident) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Ident -> Ident -> Ident
Text.replace Ident
" : " Ident
"" (Ident -> Ident) -> (Doc ann -> Ident) -> Doc ann -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Ident -> Ident -> Ident
Text.replace Ident
";" Ident
"," (Ident -> Ident) -> (Doc ann -> Ident) -> Doc ann -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream ann -> Ident
forall ann. SimpleDocStream ann -> Ident
renderStrict (SimpleDocStream ann -> Ident)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> SimpleDocStream ann
forall ann. Doc ann -> SimpleDocStream ann
layoutCompact
   pretty Type Language l Identity Identity
ty = Doc ann
-> (Type Language l Identity Identity -> Doc ann)
-> Maybe3 (Type Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty Type Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type Language l Identity Identity
-> Type (WirthySubsetOf Language) l Identity Identity
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
Type Language l Identity Identity
ty)

instance Pretty (QualIdent l) where
   pretty :: QualIdent l -> Doc ann
pretty (QualIdent [Ident]
modulePath Ident
name) = [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
dot ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Ident -> Doc ann) -> [Ident] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Ident]
modulePath [Ident] -> [Ident] -> [Ident]
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 :: 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) =
     [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann
"CASE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann)
-> (Ident -> Doc ann -> Doc ann)
-> Maybe Ident
-> Doc ann
-> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann -> Doc ann
forall a. a -> a
id (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) (Doc ann -> Doc ann -> Doc ann)
-> (Ident -> Doc ann) -> Ident -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":") (Doc ann -> Doc ann) -> (Ident -> Doc ann) -> Ident -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) Maybe Ident
localName (QualIdent l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty QualIdent l
name) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"OF"]
           [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate' Doc ann
"| " (Identity (Variant l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (Variant l l Identity Identity) -> Doc ann)
-> [Identity (Variant l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identity (Variant l l Identity Identity)
variant Identity (Variant l l Identity Identity)
-> [Identity (Variant l l Identity Identity)]
-> [Identity (Variant l l Identity Identity)]
forall a. a -> [a] -> [a]
: ZipList (Identity (Variant l l Identity Identity))
-> [Identity (Variant l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (Variant l l Identity Identity))
variants))
           [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (if ZipList (Identity (FieldList l l Identity Identity)) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ZipList (Identity (FieldList l l Identity Identity))
fallback then []
               else [Doc ann
"ELSE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<#>
                     Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
semi ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ FieldList l l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FieldList l l Identity Identity -> Doc ann)
-> (Identity (FieldList l l Identity Identity)
    -> FieldList l l Identity Identity)
-> Identity (FieldList l l Identity Identity)
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (FieldList l l Identity Identity)
-> FieldList l l Identity Identity
forall a. Identity a -> a
runIdentity (Identity (FieldList l l Identity Identity) -> Doc ann)
-> [Identity (FieldList l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (FieldList l l Identity Identity))
-> [Identity (FieldList l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (FieldList l l Identity Identity))
fallback)])
           [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann
"END"])
   pretty (FieldList IdentList l
names Identity (Type l l Identity Identity)
t) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ IdentDef l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (IdentDef l -> Doc ann) -> [IdentDef l] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdentList l -> [IdentDef l]
forall a. NonEmpty a -> [a]
toList IdentList l
names) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Type l l Identity Identity) -> 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 :: 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) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Identity (CaseLabels l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (CaseLabels l l Identity Identity) -> Doc ann)
-> [Identity (CaseLabels l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Identity (CaseLabels l l Identity Identity)
label Identity (CaseLabels l l Identity Identity)
-> [Identity (CaseLabels l l Identity Identity)]
-> [Identity (CaseLabels l l Identity Identity)]
forall a. a -> [a] -> [a]
: ZipList (Identity (CaseLabels l l Identity Identity))
-> [Identity (CaseLabels l l Identity Identity)]
forall a. ZipList a -> [a]
getZipList ZipList (Identity (CaseLabels l l Identity Identity))
labels)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":",
                                               Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
semi ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Identity (FieldList l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (FieldList l l Identity Identity) -> Doc ann)
-> [Identity (FieldList l l Identity Identity)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZipList (Identity (FieldList l l Identity Identity))
-> [Identity (FieldList l l Identity Identity)]
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 :: ProcedureHeading l l Identity Identity -> Doc ann
pretty (ProcedureHeading Ident
name Maybe (Identity (FormalParameters l l Identity Identity))
parameters) =
      Doc ann
"PROCEDURE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
name Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Maybe (Identity (FormalParameters l l Identity Identity))
-> Doc ann
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 :: [Statement Language l Identity Identity] -> Doc ann
prettyList [Statement Language l Identity Identity]
l = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> [Doc ann]
dropEmptyTail ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
semi ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Statement Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Statement Language l Identity Identity -> Doc ann)
-> [Statement Language l Identity Identity] -> [Doc ann]
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 ([Statement Language l Identity Identity] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Statement Language l Identity Identity]
l), Statement Language l Identity Identity
EmptyStatement <- [Statement Language l Identity Identity]
-> Statement Language l Identity Identity
forall a. [a] -> a
last [Statement Language l Identity Identity]
l = [Doc ann] -> [Doc ann]
forall a. [a] -> [a]
init
               | Bool
otherwise = [Doc ann] -> [Doc ann]
forall a. a -> a
id
   pretty :: 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) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"FOR" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident
index Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (ConstExpression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
from Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"TO" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (ConstExpression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (ConstExpression l l Identity Identity)
to
                                              Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann) -> Maybe (Doc ann) -> Doc ann
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Doc ann
"BY" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Identity (ConstExpression l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Identity (ConstExpression l l Identity Identity) -> Doc ann)
-> Maybe (Identity (ConstExpression l l Identity Identity))
-> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Identity (ConstExpression l l Identity Identity))
by) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"DO",
                                              Identity (StatementSequence l l Identity Identity) -> Doc ann
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) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"WITH" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Identity (Designator l l Identity Identity) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Identity (Designator l l Identity Identity)
designator Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"DO",
                                         Identity (StatementSequence l l Identity Identity) -> Doc ann
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 = Doc ann
-> (Statement Language l Identity Identity -> Doc ann)
-> Maybe3 (Statement Language) l Identity Identity
-> Doc ann
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 Doc ann
forall a. Monoid a => a
mempty Statement Language l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Statement Language l Identity Identity
-> Statement (WirthySubsetOf Language) l Identity Identity
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
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 :: Identity (StatementSequence l l Identity Identity) -> Doc ann
prettyBody (Identity StatementSequence l l Identity Identity
statements) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (StatementSequence l l Identity Identity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty StatementSequence l l Identity Identity
statements)

punctuate' :: Doc ann -> [Doc ann] -> [Doc ann]
punctuate' :: Doc ann -> [Doc ann] -> [Doc ann]
punctuate' Doc ann
p [] = []
punctuate' Doc ann
p (Doc ann
x:[Doc ann]
xs) = Doc ann
x Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((Doc ann
p Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
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 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
a, Doc ann
b]