{- |
    Module      :  $Header$
    Description :  A pretty printer for FlatCurry
    Copyright   :  (c) 2015 Björn Peemöller
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module implements a pretty printer for FlatCurry modules.
-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Curry.FlatCurry.Pretty (pPrint, pPrintPrec) where

import Prelude hiding ((<>))
import Data.Char      (ord)

import Curry.Base.Pretty
import Curry.FlatCurry.Type

instance Pretty Prog where
  pPrint :: Prog -> Doc
pPrint (Prog m :: String
m is :: [String]
is ts :: [TypeDecl]
ts fs :: [FuncDecl]
fs os :: [OpDecl]
os) = [Doc] -> Doc
sepByBlankLine
    [ String -> [TypeDecl] -> [FuncDecl] -> Doc
ppHeader String
m [TypeDecl]
ts [FuncDecl]
fs
    , [Doc] -> Doc
vcat           ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
ppImport [String]
is)
    , [Doc] -> Doc
vcat           ((OpDecl -> Doc) -> [OpDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map OpDecl -> Doc
forall a. Pretty a => a -> Doc
pPrint   [OpDecl]
os)
    , [Doc] -> Doc
sepByBlankLine ((TypeDecl -> Doc) -> [TypeDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeDecl -> Doc
forall a. Pretty a => a -> Doc
pPrint   [TypeDecl]
ts)
    , [Doc] -> Doc
sepByBlankLine ((FuncDecl -> Doc) -> [FuncDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map FuncDecl -> Doc
forall a. Pretty a => a -> Doc
pPrint   [FuncDecl]
fs)
    ]

ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc
ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc
ppHeader m :: String
m ts :: [TypeDecl]
ts fs :: [FuncDecl]
fs = [Doc] -> Doc
sep
  [String -> Doc
text "module" Doc -> Doc -> Doc
<+> String -> Doc
text String
m, [TypeDecl] -> [FuncDecl] -> Doc
ppExports [TypeDecl]
ts [FuncDecl]
fs, String -> Doc
text "where"]

-- |pretty-print the export list
ppExports :: [TypeDecl] -> [FuncDecl] -> Doc
ppExports :: [TypeDecl] -> [FuncDecl] -> Doc
ppExports ts :: [TypeDecl]
ts fs :: [FuncDecl]
fs = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
list ((TypeDecl -> Doc) -> [TypeDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeDecl -> Doc
ppTypeExport [TypeDecl]
ts [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [FuncDecl] -> [Doc]
ppFuncExports [FuncDecl]
fs)

ppTypeExport :: TypeDecl -> Doc
ppTypeExport :: TypeDecl -> Doc
ppTypeExport (Type    qn :: QName
qn vis :: Visibility
vis _ cs :: [ConsDecl]
cs)
  | Visibility
vis Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Private      = Doc
empty
  | (ConsDecl -> Bool) -> [ConsDecl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConsDecl -> Bool
isPublicCons [ConsDecl]
cs = QName -> Doc
ppPrefixOp QName
qn Doc -> Doc -> Doc
<+> String -> Doc
text "(..)"
  | Bool
otherwise           = QName -> Doc
ppPrefixOp QName
qn Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
list ([ConsDecl] -> [Doc]
ppConsExports [ConsDecl]
cs))
    where isPublicCons :: ConsDecl -> Bool
isPublicCons (Cons _ _ v :: Visibility
v _) = Visibility
v Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Public
ppTypeExport (TypeNew qn :: QName
qn vis :: Visibility
vis _ nc :: NewConsDecl
nc)
  | Visibility
vis Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Private  = Doc
empty
  | NewConsDecl -> Bool
isPublicCons NewConsDecl
nc = QName -> Doc
ppPrefixOp QName
qn Doc -> Doc -> Doc
<+> String -> Doc
text "(..)"
  | Bool
otherwise       = QName -> Doc
ppPrefixOp QName
qn Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
empty
    where isPublicCons :: NewConsDecl -> Bool
isPublicCons (NewCons _ v :: Visibility
v _) = Visibility
v Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Public
ppTypeExport (TypeSyn qn :: QName
qn vis :: Visibility
vis _ _ )
  | Visibility
vis Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Private = Doc
empty
  | Bool
otherwise      = QName -> Doc
ppPrefixOp QName
qn

-- |pretty-print the export list of constructors
ppConsExports :: [ConsDecl] -> [Doc]
ppConsExports :: [ConsDecl] -> [Doc]
ppConsExports cs :: [ConsDecl]
cs = [ QName -> Doc
ppPrefixOp QName
qn | Cons qn :: QName
qn _ Public _ <- [ConsDecl]
cs]

-- |pretty-print the export list of functions
ppFuncExports :: [FuncDecl] -> [Doc]
ppFuncExports :: [FuncDecl] -> [Doc]
ppFuncExports fs :: [FuncDecl]
fs = [ QName -> Doc
ppPrefixOp QName
qn | Func qn :: QName
qn _ Public _ _ <- [FuncDecl]
fs]

-- |pretty-print an import statement
ppImport :: String -> Doc
ppImport :: String -> Doc
ppImport m :: String
m = String -> Doc
text "import" Doc -> Doc -> Doc
<+> String -> Doc
text String
m

instance Pretty OpDecl where
  pPrint :: OpDecl -> Doc
pPrint(Op qn :: QName
qn fix :: Fixity
fix n :: Integer
n) = Fixity -> Doc
forall a. Pretty a => a -> Doc
pPrint Fixity
fix Doc -> Doc -> Doc
<+> Integer -> Doc
integer Integer
n Doc -> Doc -> Doc
<+> QName -> Doc
ppInfixOp QName
qn

instance Pretty Fixity where
  pPrint :: Fixity -> Doc
pPrint InfixOp  = String -> Doc
text "infix"
  pPrint InfixlOp = String -> Doc
text "infixl"
  pPrint InfixrOp = String -> Doc
text "infixr"

instance Pretty TypeDecl where
  pPrint :: TypeDecl -> Doc
pPrint (Type    qn :: QName
qn _ vs :: [TVarWithKind]
vs cs :: [ConsDecl]
cs) = String -> Doc
text "data" Doc -> Doc -> Doc
<+> QName -> Doc
ppQName QName
qn
    Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> Doc
ppTVarIndex (Int -> Doc) -> (TVarWithKind -> Int) -> TVarWithKind -> Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarWithKind -> Int
forall a b. (a, b) -> a
fst (TVarWithKind -> Doc) -> [TVarWithKind] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TVarWithKind]
vs) Doc -> Doc -> Doc
$+$ [ConsDecl] -> Doc
ppConsDecls [ConsDecl]
cs
  pPrint (TypeSyn qn :: QName
qn _ vs :: [TVarWithKind]
vs ty :: TypeExpr
ty) = String -> Doc
text "type" Doc -> Doc -> Doc
<+> QName -> Doc
ppQName QName
qn
    Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> Doc
ppTVarIndex (Int -> Doc) -> (TVarWithKind -> Int) -> TVarWithKind -> Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarWithKind -> Int
forall a b. (a, b) -> a
fst (TVarWithKind -> Doc) -> [TVarWithKind] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TVarWithKind]
vs) Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 TypeExpr
ty
  pPrint (TypeNew qn :: QName
qn _ vs :: [TVarWithKind]
vs nc :: NewConsDecl
nc) = String -> Doc
text "newtype" Doc -> Doc -> Doc
<+> QName -> Doc
ppQName QName
qn
    Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> Doc
ppTVarIndex (Int -> Doc) -> (TVarWithKind -> Int) -> TVarWithKind -> Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarWithKind -> Int
forall a b. (a, b) -> a
fst (TVarWithKind -> Doc) -> [TVarWithKind] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TVarWithKind]
vs) Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> NewConsDecl -> Doc
forall a. Pretty a => a -> Doc
pPrint NewConsDecl
nc

-- |pretty-print the constructor declarations
ppConsDecls :: [ConsDecl] -> Doc
ppConsDecls :: [ConsDecl] -> Doc
ppConsDecls cs :: [ConsDecl]
cs = Doc -> Doc
indent (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
  (Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) (Doc
equals Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat (Char -> Doc
char '|')) ((ConsDecl -> Doc) -> [ConsDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ConsDecl -> Doc
forall a. Pretty a => a -> Doc
pPrint [ConsDecl]
cs)

instance Pretty ConsDecl where
  pPrint :: ConsDecl -> Doc
pPrint (Cons qn :: QName
qn _ _ tys :: [TypeExpr]
tys) = [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
ppPrefixOp QName
qn Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (TypeExpr -> Doc) -> [TypeExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 2) [TypeExpr]
tys

instance Pretty NewConsDecl where
  pPrint :: NewConsDecl -> Doc
pPrint (NewCons qn :: QName
qn _ ty :: TypeExpr
ty) = [Doc] -> Doc
fsep [QName -> Doc
forall a. Pretty a => a -> Doc
pPrint QName
qn, Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 2 TypeExpr
ty]

instance Pretty TypeExpr where
  pPrintPrec :: Int -> TypeExpr -> Doc
pPrintPrec _ (TVar           i :: Int
i) = Int -> Doc
ppTVarIndex Int
i
  pPrintPrec p :: Int
p (FuncType ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep
    [Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1 TypeExpr
ty1, Doc
rarrow, Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 TypeExpr
ty2]
  pPrintPrec p :: Int
p (TCons     qn :: QName
qn tys :: [TypeExpr]
tys) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([TypeExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeExpr]
tys)) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep
    (QName -> Doc
ppPrefixOp QName
qn Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (TypeExpr -> Doc) -> [TypeExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 2) [TypeExpr]
tys)
  pPrintPrec p :: Int
p (ForallType vs :: [TVarWithKind]
vs ty :: TypeExpr
ty)
    | [TVarWithKind] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TVarWithKind]
vs   = Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec Int
p TypeExpr
ty
    | Bool
otherwise = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [TVarWithKind] -> Doc
ppQuantifiedVars [TVarWithKind]
vs Doc -> Doc -> Doc
<+> Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 TypeExpr
ty

-- |pretty-print explicitly quantified type variables (without kinds)
ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc
ppQuantifiedVars :: [TVarWithKind] -> Doc
ppQuantifiedVars vs :: [TVarWithKind]
vs
  | [TVarWithKind] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TVarWithKind]
vs = Doc
empty
  | Bool
otherwise = String -> Doc
text "forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TVarWithKind -> Doc) -> [TVarWithKind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TVarWithKind -> Doc
ppTVar [TVarWithKind]
vs) Doc -> Doc -> Doc
<> Char -> Doc
char '.'

ppTVar :: (TVarIndex, Kind) -> Doc
ppTVar :: TVarWithKind -> Doc
ppTVar (i :: Int
i, _) = Int -> Doc
ppTVarIndex Int
i

-- |pretty-print a type variable
ppTVarIndex :: TVarIndex -> Doc
ppTVarIndex :: Int -> Doc
ppTVarIndex i :: Int
i = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String]
vars [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
i
  where vars :: [String]
vars = [ if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then [Char
c] else Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n
               | Int
n <- [0 :: Int ..], Char
c <- ['a' .. 'z']
               ]

instance Pretty FuncDecl where
  pPrint :: FuncDecl -> Doc
pPrint (Func qn :: QName
qn _ _ ty :: TypeExpr
ty r :: Rule
r)
    = [Doc] -> Doc
hsep [QName -> Doc
ppPrefixOp QName
qn, String -> Doc
text "::", Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 TypeExpr
ty]
      Doc -> Doc -> Doc
$+$ QName -> Doc
ppPrefixOp QName
qn Doc -> Doc -> Doc
<+> Rule -> Doc
forall a. Pretty a => a -> Doc
pPrint Rule
r

instance Pretty Rule where
  pPrint :: Rule -> Doc
pPrint (Rule  vs :: [Int]
vs e :: Expr
e) =
    [Doc] -> Doc
fsep ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
ppVarIndex [Int]
vs) Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Doc -> Doc
indent (Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e)
  pPrint (External _) = String -> Doc
text "external"

instance Pretty Expr where
  pPrintPrec :: Int -> Expr -> Doc
pPrintPrec _ (Var        v :: Int
v) = Int -> Doc
ppVarIndex Int
v
  pPrintPrec _ (Lit        l :: Literal
l) = Literal -> Doc
forall a. Pretty a => a -> Doc
pPrint Literal
l
  pPrintPrec p :: Int
p (Comb _ qn :: QName
qn es :: [Expr]
es) = Int -> QName -> [Expr] -> Doc
ppComb Int
p QName
qn [Expr]
es
  pPrintPrec p :: Int
p (Free    vs :: [Int]
vs e :: Expr
e)
    | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
vs             = Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec Int
p Expr
e
    | Bool
otherwise           = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
                            [ String -> Doc
text "let" Doc -> Doc -> Doc
<+> [Doc] -> Doc
list ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
ppVarIndex [Int]
vs)
                                         Doc -> Doc -> Doc
<+> String -> Doc
text "free"
                            , String -> Doc
text "in"  Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e
                            ]
  pPrintPrec p :: Int
p (Let     ds :: [(Int, Expr)]
ds e :: Expr
e) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
sep [String -> Doc
text "let" Doc -> Doc -> Doc
<+> [(Int, Expr)] -> Doc
ppDecls [(Int, Expr)]
ds, String -> Doc
text "in" Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e]
  pPrintPrec p :: Int
p (Or     e1 :: Expr
e1 e2 :: Expr
e2) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1 Expr
e1 Doc -> Doc -> Doc
<+> String -> Doc
text "?" Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1 Expr
e2
  pPrintPrec p :: Int
p (Case ct :: CaseType
ct e :: Expr
e bs :: [BranchExpr]
bs) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    CaseType -> Doc
forall a. Pretty a => a -> Doc
pPrint CaseType
ct Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e Doc -> Doc -> Doc
<+> String -> Doc
text "of" Doc -> Doc -> Doc
$$ Doc -> Doc
indent ([Doc] -> Doc
vcat ((BranchExpr -> Doc) -> [BranchExpr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map BranchExpr -> Doc
forall a. Pretty a => a -> Doc
pPrint [BranchExpr]
bs))
  pPrintPrec p :: Int
p (Typed   e :: Expr
e ty :: TypeExpr
ty) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> Int -> TypeExpr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 TypeExpr
ty

-- |pretty-print a variable
ppVarIndex :: VarIndex -> Doc
ppVarIndex :: Int -> Doc
ppVarIndex i :: Int
i = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ 'v' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i

instance Pretty Literal where
  pPrint :: Literal -> Doc
pPrint (Intc   i :: Integer
i) = Integer -> Doc
integer Integer
i
  pPrint (Floatc f :: Double
f) = Double -> Doc
double  Double
f
  pPrint (Charc  c :: Char
c) = String -> Doc
text (Char -> String
showEscape Char
c)

-- |Escape character literal
showEscape :: Char -> String
showEscape :: Char -> String
showEscape c :: Char
c
  | Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<   10  = "'\\00" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
  | Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<   32  = "'\\0"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
  | Int
o Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 127  = "'\\127'"
  | Bool
otherwise = Char -> String
forall a. Show a => a -> String
show Char
c
  where o :: Int
o = Char -> Int
ord Char
c

-- |Pretty print a constructor or function call
ppComb :: Int -> QName -> [Expr] -> Doc
ppComb :: Int -> QName -> [Expr] -> Doc
ppComb _ qn :: QName
qn []      = QName -> Doc
ppPrefixOp QName
qn
ppComb p :: Int
p qn :: QName
qn [e1 :: Expr
e1,e2 :: Expr
e2]
  | QName -> Bool
isInfixOp QName
qn    = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0)
                    (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1 Expr
e1, QName -> Doc
forall a. Pretty a => a -> Doc
pPrint QName
qn, Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1 Expr
e2]
ppComb p :: Int
p qn :: QName
qn es :: [Expr]
es      = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0)
                    (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep (QName -> Doc
ppPrefixOp QName
qn Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Expr -> Doc) -> [Expr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 1) [Expr]
es)

-- |pretty-print a list of declarations
ppDecls :: [(VarIndex, Expr)] -> Doc
ppDecls :: [(Int, Expr)] -> Doc
ppDecls = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([(Int, Expr)] -> [Doc]) -> [(Int, Expr)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Expr) -> Doc) -> [(Int, Expr)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Expr) -> Doc
ppDecl

-- |pretty-print a single declaration
ppDecl :: (VarIndex, Expr) -> Doc
ppDecl :: (Int, Expr) -> Doc
ppDecl (v :: Int
v, e :: Expr
e) = Int -> Doc
ppVarIndex Int
v Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e

instance Pretty CaseType where
  pPrint :: CaseType -> Doc
pPrint Rigid = String -> Doc
text "case"
  pPrint Flex  = String -> Doc
text "fcase"

instance Pretty BranchExpr where
  pPrint :: BranchExpr -> Doc
pPrint (Branch p :: Pattern
p e :: Expr
e) = Pattern -> Doc
forall a. Pretty a => a -> Doc
pPrint Pattern
p Doc -> Doc -> Doc
<+> Doc
rarrow Doc -> Doc -> Doc
<+> Int -> Expr -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expr
e

instance Pretty Pattern where
  pPrint :: Pattern -> Doc
pPrint (Pattern c :: QName
c [v1 :: Int
v1,v2 :: Int
v2])
    | QName -> Bool
isInfixOp QName
c            = Int -> Doc
ppVarIndex Int
v1 Doc -> Doc -> Doc
<+> QName -> Doc
ppInfixOp QName
c Doc -> Doc -> Doc
<+> Int -> Doc
ppVarIndex Int
v2
  pPrint (Pattern  c :: QName
c     vs :: [Int]
vs) = [Doc] -> Doc
fsep (QName -> Doc
ppPrefixOp QName
c Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
ppVarIndex [Int]
vs)
  pPrint (LPattern        l :: Literal
l) = Literal -> Doc
forall a. Pretty a => a -> Doc
pPrint Literal
l

-- Names

-- |pretty-print a prefix operator
ppPrefixOp :: QName -> Doc
ppPrefixOp :: QName -> Doc
ppPrefixOp qn :: QName
qn = Bool -> Doc -> Doc
parenIf (QName -> Bool
isInfixOp QName
qn) (QName -> Doc
ppQName QName
qn)

-- |pretty-print a name in infix manner
ppInfixOp :: QName -> Doc
ppInfixOp :: QName -> Doc
ppInfixOp qn :: QName
qn = if QName -> Bool
isInfixOp QName
qn then QName -> Doc
ppQName QName
qn else Doc -> Doc
bquotes (QName -> Doc
ppQName QName
qn)

-- |pretty-print a qualified name
ppQName :: QName -> Doc
ppQName :: QName -> Doc
ppQName (m :: String
m, i :: String
i) = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ '.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
i

-- |Check whether an operator is an infix operator
isInfixOp :: QName -> Bool
isInfixOp :: QName -> Bool
isInfixOp = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "~!@#$%^&*+-=<>:?./|\\") (String -> Bool) -> (QName -> String) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
forall a b. (a, b) -> b
snd

-- Indentation
indent :: Doc -> Doc
indent :: Doc -> Doc
indent = Int -> Doc -> Doc
nest 2