{-# OPTIONS_GHC -Wunused-imports #-}

------------------------------------------------------------------------
-- Pretty-printing of Haskell modules
------------------------------------------------------------------------

module Agda.Compiler.MAlonzo.Pretty where

import qualified Agda.Utils.Haskell.Syntax as HS

import Agda.Compiler.MAlonzo.Encode
import Agda.Syntax.Common.Pretty

import Agda.Utils.Null (empty)
import Agda.Utils.Function (applyWhen)


prettyPrint :: Pretty a => a -> String
prettyPrint :: forall a. Pretty a => a -> String
prettyPrint = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty

instance Pretty HS.Module where
  pretty :: Module -> Doc
pretty (HS.Module ModuleName
m [ModulePragma]
pragmas [ImportDecl]
imps [Decl]
decls) =
    [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ (ModulePragma -> Doc) -> [ModulePragma] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModulePragma -> Doc
forall a. Pretty a => a -> Doc
pretty [ModulePragma]
pragmas
      , [ Doc
"" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ModulePragma] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModulePragma]
pragmas ]
      , [ Doc
"module" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"where" ]
      , [ Doc
"" ]
      , (ImportDecl -> Doc) -> [ImportDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [ImportDecl]
imps
      , [ Doc
"" ]
      , (Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> Doc
forall a. Pretty a => a -> Doc
pretty [Decl]
decls
      ]

instance Pretty HS.ModulePragma where
  pretty :: ModulePragma -> Doc
pretty (HS.LanguagePragma [Name]
ps) =
    Doc
"{-#" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"LANGUAGE" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
ps) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"#-}"
  pretty (HS.OtherPragma String
p) =
    String -> Doc
forall a. String -> Doc a
text String
p

instance Pretty HS.ImportDecl where
  pretty :: ImportDecl -> Doc
pretty HS.ImportDecl{ importModule :: ImportDecl -> ModuleName
HS.importModule    = ModuleName
m
                      , importQualified :: ImportDecl -> Bool
HS.importQualified = Bool
q
                      , importSpecs :: ImportDecl -> Maybe (Bool, [ImportSpec])
HS.importSpecs     = Maybe (Bool, [ImportSpec])
specs } =
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ Doc
"import"
           , if Bool
q then Doc
"qualified" else Doc
forall a. Null a => a
empty
           , ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m
           , Doc
-> ((Bool, [ImportSpec]) -> Doc)
-> Maybe (Bool, [ImportSpec])
-> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Null a => a
empty (Bool, [ImportSpec]) -> Doc
forall {a}. Pretty a => (Bool, [a]) -> Doc
prSpecs Maybe (Bool, [ImportSpec])
specs ]
    where prSpecs :: (Bool, [a]) -> Doc
prSpecs (Bool
hide, [a]
specs) =
            [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ if Bool
hide then Doc
"hiding" else Doc
forall a. Null a => a
empty
                 , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty [a]
specs ]

instance Pretty HS.ImportSpec where
  pretty :: ImportSpec -> Doc
pretty (HS.IVar Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x

instance Pretty HS.Decl where
  pretty :: Decl -> Doc
pretty = \case
    HS.TypeDecl Name
f [TyVarBind]
xs Type
t ->
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"type" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"="
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
    HS.DataDecl DataOrNew
newt Name
d [TyVarBind]
xs [ConDecl]
cons [Deriving]
derv ->
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ DataOrNew -> Doc
forall a. Pretty a => a -> Doc
pretty DataOrNew
newt Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
d Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ if [ConDecl] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConDecl]
cons then Doc
forall a. Null a => a
empty
                     else Doc
"=" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
" |" ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ConDecl -> Doc) -> [ConDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ConDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [ConDecl]
cons)
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Deriving] -> Doc
forall {t :: * -> *}. Foldable t => [(QName, t Type)] -> Doc
prDeriving [Deriving]
derv ]
      where
        prDeriving :: [(QName, t Type)] -> Doc
prDeriving [] = Doc
forall a. Null a => a
empty
        prDeriving [(QName, t Type)]
ds = Doc
"deriving" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
parens ([Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((QName, t Type) -> Doc) -> [(QName, t Type)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName, t Type) -> Doc
forall {t :: * -> *}. Foldable t => (QName, t Type) -> Doc
prDer [(QName, t Type)]
ds)
        prDer :: (QName, t Type) -> Doc
prDer (QName
d, t Type
ts) = Type -> Doc
forall a. Pretty a => a -> Doc
pretty ((Type -> Type -> Type) -> Type -> t Type -> Type
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
HS.TyApp (QName -> Type
HS.TyCon QName
d) t Type
ts)
    HS.TypeSig [Name]
fs Type
t ->
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
fs)) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"::"
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
    HS.FunBind [Match]
ms -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Match -> Doc) -> [Match] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Match -> Doc
forall a. Pretty a => a -> Doc
pretty [Match]
ms
    HS.LocalBind Strictness
s Name
f Rhs
rhs ->
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Strictness -> Doc
forall a. Pretty a => a -> Doc
pretty Strictness
s Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"=" Rhs
rhs
          ]
    HS.PatSyn Pat
p1 Pat
p2 -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"pattern" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p1 Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"=" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p2 ]
    HS.FakeDecl String
s -> String -> Doc
forall a. String -> Doc a
text String
s
    HS.Comment String
s -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc
"--" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+>) (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
forall a. String -> Doc a
text) (String -> [String]
lines String
s)

instance Pretty HS.ConDecl where
  pretty :: ConDecl -> Doc
pretty (HS.ConDecl Name
c [(Maybe Strictness, Type)]
sts) =
    Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
c Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+>
    [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (((Maybe Strictness, Type) -> Doc)
-> [(Maybe Strictness, Type)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe Strictness
s, Type
t) -> Doc -> (Strictness -> Doc) -> Maybe Strictness -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Null a => a
empty Strictness -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe Strictness
s Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10 Type
t) [(Maybe Strictness, Type)]
sts)

instance Pretty HS.Strictness where
  pretty :: Strictness -> Doc
pretty Strictness
HS.Strict = Doc
"!"
  pretty Strictness
HS.Lazy   = Doc
forall a. Null a => a
empty

instance Pretty HS.Match where
  pretty :: Match -> Doc
pretty (HS.Match Name
f [Pat]
ps Rhs
rhs Maybe Binds
wh) =
    Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
          , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"=" Rhs
rhs ]

prettyWhere :: Maybe HS.Binds -> Doc -> Doc
prettyWhere :: Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
Nothing  Doc
doc = Doc
doc
prettyWhere (Just Binds
b) Doc
doc =
  [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
doc, Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"where", Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Binds -> Doc
forall a. Pretty a => a -> Doc
pretty Binds
b ] ]

instance Pretty HS.Pat where
  prettyPrec :: Int -> Pat -> Doc
prettyPrec Int
pr Pat
pat =
    case Pat
pat of
      HS.PVar Name
x         -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
      HS.PLit Literal
l         -> Int -> Literal -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
pr Literal
l
      HS.PAsPat Name
x Pat
p     -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
      Pat
HS.PWildCard      -> Doc
"_"
      HS.PBangPat Pat
p     -> Doc
"!" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
      HS.PApp QName
c [Pat]
ps      -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
      HS.PatTypeSig Pat
p Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"::", Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.PIrrPat Pat
p      -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"~" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p

prettyRhs :: String -> HS.Rhs -> Doc
prettyRhs :: String -> Rhs -> Doc
prettyRhs String
eq (HS.UnGuardedRhs Exp
e)   = String -> Doc
forall a. String -> Doc a
text String
eq Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
prettyRhs String
eq (HS.GuardedRhss [GuardedRhs]
rhss) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (GuardedRhs -> Doc) -> [GuardedRhs] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> GuardedRhs -> Doc
prettyGuardedRhs String
eq) [GuardedRhs]
rhss

prettyGuardedRhs :: String -> HS.GuardedRhs -> Doc
prettyGuardedRhs :: String -> GuardedRhs -> Doc
prettyGuardedRhs String
eq (HS.GuardedRhs [Stmt]
ss Exp
e) =
    [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"|" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Stmt -> Doc) -> [Stmt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Stmt -> Doc
forall a. Pretty a => a -> Doc
pretty [Stmt]
ss) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> String -> Doc
forall a. String -> Doc a
text String
eq
        , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]

instance Pretty HS.Binds where
  pretty :: Binds -> Doc
pretty (HS.BDecls [Decl]
ds) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> Doc
forall a. Pretty a => a -> Doc
pretty [Decl]
ds

instance Pretty HS.DataOrNew where
  pretty :: DataOrNew -> Doc
pretty DataOrNew
HS.DataType = Doc
"data"
  pretty DataOrNew
HS.NewType  = Doc
"newtype"

instance Pretty HS.TyVarBind where
  pretty :: TyVarBind -> Doc
pretty (HS.UnkindedVar Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x

instance Pretty HS.Type where
  prettyPrec :: Int -> Type -> Doc
prettyPrec Int
pr Type
t =
    case Type
t of
      HS.TyForall [TyVarBind]
xs Type
t ->
        Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ (Doc
"forall" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
              , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.TyFun Type
a Type
b ->
        Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
5 Type
a Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"->", Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
4 Type
b ]
      HS.TyCon QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
      HS.TyVar Name
x -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
      HS.TyApp (HS.TyCon (HS.UnQual (HS.Ident String
"[]"))) Type
t ->
        Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t
      t :: Type
t@HS.TyApp{} ->
        Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Type
f
              , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Type]
ts ]
        where
          Type
f : [Type]
ts = Type -> [Type] -> [Type]
appView Type
t []
          appView :: Type -> [Type] -> [Type]
appView (HS.TyApp Type
a Type
b) [Type]
as = Type -> [Type] -> [Type]
appView Type
a (Type
b Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as)
          appView Type
t [Type]
as = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as
      HS.FakeType String
s -> String -> Doc
forall a. String -> Doc a
text String
s

instance Pretty HS.Stmt where
  pretty :: Stmt -> Doc
pretty (HS.Qualifier Exp
e) = Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
  pretty (HS.Generator Pat
p Exp
e) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"<-", Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]

instance Pretty HS.Literal where
  prettyPrec :: Int -> Literal -> Doc
prettyPrec Int
pr = \case
    HS.Int Integer
n    -> Integer -> Doc -> Doc
forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Integer
n (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Integer -> Doc
forall a. Integer -> Doc a
integer Integer
n
    HS.Frac Rational
x   -> Double -> Doc -> Doc
forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Double
d (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Double -> Doc
forall a. Double -> Doc a
double Double
d
                   where
                   d :: Double
d = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x
    HS.Char Char
c   -> String -> Doc
forall a. String -> Doc a
text (Char -> String
forall a. Show a => a -> String
show Char
c)
    HS.String Text
s -> String -> Doc
forall a. String -> Doc a
text (Text -> String
forall a. Show a => a -> String
show Text
s)
    where
    parensIfNeg :: (Ord n, Num n) => n -> Doc -> Doc
    parensIfNeg :: forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg n
x = Bool -> (Doc -> Doc) -> Doc -> Doc
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0) ((Doc -> Doc) -> Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)

instance Pretty HS.Exp where
  prettyPrec :: Int -> Exp -> Doc
prettyPrec Int
pr Exp
e =
    case Exp
e of
      HS.Var QName
x -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
      HS.Con QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
      HS.Lit Literal
l -> Literal -> Doc
forall a. Pretty a => a -> Doc
pretty Literal
l
      HS.InfixApp Exp
a QOp
qop Exp
b -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
a
            , QOp -> Doc
forall a. Pretty a => a -> Doc
pretty QOp
qop Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
b ]
      HS.Ann Exp
e Type
ty -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
e
            , Doc
"::"
            , Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Type
ty
            ]
      HS.App{} -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Exp
f
            , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Exp]
es ]
        where
          Exp
f : [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
e []
          appView :: Exp -> [Exp] -> [Exp]
appView (HS.App Exp
f Exp
e) [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
f (Exp
e Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es)
          appView Exp
f [Exp]
es = Exp
f Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es
      HS.Lambda [Pat]
ps Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"\\" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps) Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"->"
            , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
      HS.Let Binds
bs Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"let" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Binds -> Doc
forall a. Pretty a => a -> Doc
pretty Binds
bs Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"in"
            , Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
      HS.If Exp
a Exp
b Exp
c -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"if" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
a
            , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"then" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
b
            , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"else" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
c ]
      HS.Case Exp
e [Alt]
bs -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
"case" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"of"
             , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Alt -> Doc) -> [Alt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Alt -> Doc
forall a. Pretty a => a -> Doc
pretty [Alt]
bs ]
      HS.ExpTypeSig Exp
e Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"::"
            , Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.NegApp Exp
exp -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
exp
      HS.FakeExp String
s -> String -> Doc
forall a. String -> Doc a
text String
s

instance Pretty HS.Alt where
  pretty :: Alt -> Doc
pretty (HS.Alt Pat
pat Rhs
rhs Maybe Binds
wh) =
    Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
pat, Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"->" Rhs
rhs ]

instance Pretty HS.ModuleName where
  pretty :: ModuleName -> Doc
pretty ModuleName
m = String -> Doc
forall a. String -> Doc a
text String
s
    where HS.ModuleName String
s = ModuleName -> ModuleName
encodeModuleName ModuleName
m

instance Pretty HS.QName where
  pretty :: QName -> Doc
pretty QName
q = Bool -> Doc -> Doc
mparens (QName -> Bool
isOperator QName
q) (QName -> Doc
prettyQName QName
q)

instance Pretty HS.Name where
  pretty :: Name -> Doc
pretty (HS.Ident  String
s) = String -> Doc
forall a. String -> Doc a
text String
s
  pretty (HS.Symbol String
s) = String -> Doc
forall a. String -> Doc a
text String
s

instance Pretty HS.QOp where
  pretty :: QOp -> Doc
pretty (HS.QVarOp QName
x)
    | QName -> Bool
isOperator QName
x = QName -> Doc
prettyQName QName
x
    | Bool
otherwise    = Doc
"`" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> QName -> Doc
prettyQName QName
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"`"

isOperator :: HS.QName -> Bool
isOperator :: QName -> Bool
isOperator QName
q =
  case QName
q of
    HS.Qual ModuleName
_ Name
x           -> Name -> Bool
isOp Name
x
    HS.UnQual Name
x           -> Name -> Bool
isOp Name
x
  where
    isOp :: Name -> Bool
isOp HS.Symbol{} = Bool
True
    isOp HS.Ident{}  = Bool
False

prettyQName :: HS.QName -> Doc
prettyQName :: QName -> Doc
prettyQName (HS.Qual ModuleName
m Name
x)           = ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
prettyQName (HS.UnQual Name
x)           = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x