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

module Agda.Compiler.MAlonzo.Pretty where

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

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


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