    {-# LANGUAGE CPP #-}

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

    module Agda.Compiler.MAlonzo.Pretty where

    #if MIN_VERSION_base(4,11,0)
    import Prelude hiding ((<>))
    #endif

    import Data.Generics.Geniplate
    import qualified Agda.Utils.Haskell.Syntax as HS
    import Text.PrettyPrint (empty)

    import Agda.Compiler.MAlonzo.Encode
    import Agda.Utils.Pretty
    import Agda.Utils.Impossible

    #include "undefined.h"

    prettyPrint :: Pretty a => a -> String
    prettyPrint = show . pretty

    instance Pretty HS.Module where
      pretty (HS.Module m pragmas imps decls) =
        vcat [ vcat $ map pretty pragmas
             , "module" <+> pretty m <+> "where"
             , ""
             , vcat $ map pretty imps
             , ""
             , vcat $ map pretty decls ]

    instance Pretty HS.ModulePragma where
      pretty (HS.LanguagePragma ps) =
        "{-#" <+> "LANGUAGE" <+> fsep (punctuate comma $ map pretty ps) <+> "#-}"
      pretty (HS.OtherPragma p) =
        text p

    instance Pretty HS.ImportDecl where
      pretty HS.ImportDecl{ HS.importModule    = m
                          , HS.importQualified = q
                          , HS.importSpecs     = specs } =
          hsep [ "import"
               , if q then "qualified" else empty
               , pretty m
               , maybe empty prSpecs specs ]
        where prSpecs (hide, specs) =
                hsep [ if hide then "hiding" else empty
                     , parens $ fsep $ punctuate comma $ map pretty specs ]

    instance Pretty HS.ImportSpec where
      pretty (HS.IVar x) = pretty x

    instance Pretty HS.Decl where
      pretty d = case d of
        HS.TypeDecl f xs t ->
          sep [ "type" <+> pretty f <+> fsep (map pretty xs) <+> "="
              , nest 2 $ pretty t ]
        HS.DataDecl newt d xs cons derv ->
          sep [ pretty newt <+> pretty d <+> fsep (map pretty xs)
              , nest 2 $ if null cons then empty
                         else "=" <+> fsep (punctuate " |" $ map pretty cons)
              , nest 2 $ prDeriving derv ]
          where
            prDeriving [] = empty
            prDeriving ds = "deriving" <+> parens (fsep $ punctuate comma $ map prDer ds)
            prDer (d, ts) = pretty (foldl HS.TyApp (HS.TyCon d) ts)
        HS.TypeSig fs t ->
          sep [ hsep (punctuate comma (map pretty fs)) <+> "::"
              , nest 2 $ pretty t ]
        HS.FunBind ms -> vcat $ map pretty ms
        HS.PatSyn p1 p2 -> sep [ "pattern" <+> pretty p1 <+> "=" <+> pretty p2 ]
        HS.FakeDecl s -> text s

    instance Pretty HS.ConDecl where
      pretty (HS.ConDecl c sts) =
        pretty c <+>
        fsep (map (\(s, t) -> maybe empty pretty s <> prettyPrec 10 t) sts)

    instance Pretty HS.Strictness where
      pretty HS.Strict = "!"
      pretty HS.Lazy   = empty

    instance Pretty HS.Match where
      pretty (HS.Match f ps rhs wh) =
        prettyWhere wh $
          sep [ pretty f <+> fsep (map (prettyPrec 10) ps)
              , nest 2 $ prettyRhs "=" rhs ]

    prettyWhere :: Maybe HS.Binds -> Doc -> Doc
    prettyWhere Nothing  doc = doc
    prettyWhere (Just b) doc =
      vcat [ doc, nest 2 $ sep [ "where", nest 2 $ pretty b ] ]

    instance Pretty HS.Pat where
      prettyPrec pr pat =
        case pat of
          HS.PVar x         -> pretty x
          HS.PLit l         -> pretty l
          HS.PAsPat x p     -> mparens (pr > 10) $ pretty x <> "@" <> prettyPrec 11 p
          HS.PWildCard      -> "_"
          HS.PBangPat p     -> "!" <> prettyPrec 11 p
          HS.PApp c ps      -> mparens (pr > 9) $ pretty c <+> hsep (map (prettyPrec 10) ps)
          HS.PatTypeSig p t -> mparens (pr > 0) $ sep [ pretty p <+> "::", nest 2 $ pretty t ]
          HS.PIrrPat p      -> mparens (pr > 10) $ "~" <> prettyPrec 11 p

    prettyRhs :: String -> HS.Rhs -> Doc
    prettyRhs eq (HS.UnGuardedRhs e)   = text eq <+> pretty e
    prettyRhs eq (HS.GuardedRhss rhss) = vcat $ map (prettyGuardedRhs eq) rhss

    prettyGuardedRhs :: String -> HS.GuardedRhs -> Doc
    prettyGuardedRhs eq (HS.GuardedRhs ss e) =
        sep [ "|" <+> sep (punctuate comma $ map pretty ss) <+> text eq
            , nest 2 $ pretty e ]

    instance Pretty HS.Binds where
      pretty (HS.BDecls ds) = vcat $ map pretty ds

    instance Pretty HS.DataOrNew where
      pretty HS.DataType = "data"
      pretty HS.NewType  = "newtype"

    instance Pretty HS.TyVarBind where
      pretty (HS.UnkindedVar x) = pretty x

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

    instance Pretty HS.Stmt where
      pretty (HS.Qualifier e) = pretty e
      pretty (HS.Generator p e) = sep [ pretty p <+> "<-", nest 2 $ pretty e ]

    instance Pretty HS.Literal where
      pretty (HS.Int n)    = integer n
      pretty (HS.Frac x)   = double (fromRational x)
      pretty (HS.Char c)   = text (show c)
      pretty (HS.String s) = text (show s)

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

    instance Pretty HS.Alt where
      pretty (HS.Alt pat rhs wh) =
        prettyWhere wh $
          sep [ pretty pat, nest 2 $ prettyRhs "->" rhs ]

    instance Pretty HS.ModuleName where
      pretty m = text s
        where HS.ModuleName s = encodeModuleName m

    instance Pretty HS.QName where
      pretty q = mparens (isOperator q) (prettyQName q)

    instance Pretty HS.Name where
      pretty (HS.Ident  s) = text s
      pretty (HS.Symbol s) = text s

    instance Pretty HS.QOp where
      pretty (HS.QVarOp x)
        | isOperator x = prettyQName x
        | otherwise    = "`" <> prettyQName x <> "`"

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

    prettyQName :: HS.QName -> Doc
    prettyQName (HS.Qual m x)           = pretty m <> "." <> pretty x
    prettyQName (HS.UnQual x)           = pretty x