{- |
    Module      :  $Header$
    Description :  A pretty printer for Curry
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2016        Finn Teegen
    License     :  BSD-3-clause

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

    This module implements a pretty printer for Curry expressions. It was
    derived from the Haskell pretty printer provided in Simon Marlow's
    Haskell parser.
-}
{-# LANGUAGE CPP #-}
module Curry.Syntax.Pretty
  ( ppModule, ppInterface, ppIDecl, ppDecl, ppIdent, ppPattern, ppFieldPatt
  , ppExpr, ppOp, ppStmt, ppFieldExpr, ppQualTypeExpr, ppTypeExpr, ppKindExpr
  , ppAlt, ppQIdent, ppConstraint, ppInstanceType, ppConstr, ppNewConstr
  , ppFieldDecl, ppEquation, ppMIdent
  ) where

#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

import Curry.Base.Ident
import Curry.Base.Pretty

import Curry.Syntax.Type
import Curry.Syntax.Utils (opName)

-- TODO use span infos

-- |Pretty print a module
ppModule :: Module a -> Doc
ppModule (Module _ ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds

ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec
               -> [ImportDecl] -> Doc
ppModuleHeader ps m es is
  | null is   = header
  | otherwise = header $+$ text "" $+$ (vcat $ map ppImportDecl is)
  where header = (vcat $ map ppModulePragma ps)
                 $+$ text "module" <+> ppMIdent m
                 <+> maybePP ppExportSpec es <+> text "where"

ppModulePragma :: ModulePragma -> Doc
ppModulePragma (LanguagePragma _      exts) =
  ppPragma "LANGUAGE" $ list $ map ppExtension exts
ppModulePragma (OptionsPragma  _ tool args) =
  ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . ppTool) tool <+> text args

ppPragma :: String -> Doc -> Doc
ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}"

ppExtension :: Extension -> Doc
ppExtension (KnownExtension   _ e) = text (show e)
ppExtension (UnknownExtension _ e) = text e

ppTool :: Tool -> Doc
ppTool (UnknownTool t) = text t
ppTool t               = text (show t)

ppExportSpec :: ExportSpec -> Doc
ppExportSpec (Exporting _ es) = parenList (map ppExport es)

ppExport :: Export -> Doc
ppExport (Export             _ x) = ppQIdent x
ppExport (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs)
ppExport (ExportTypeAll     _ tc) = ppQIdent tc <> text "(..)"
ppExport (ExportModule       _ m) = text "module" <+> ppMIdent m

ppImportDecl :: ImportDecl -> Doc
ppImportDecl (ImportDecl _ m q asM is) =
  text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM
                <+> maybePP ppImportSpec is
  where ppQualified q' = if q' then text "qualified" else empty
        ppAs m' = text "as" <+> ppMIdent m'

ppImportSpec :: ImportSpec -> Doc
ppImportSpec (Importing _ is) = parenList (map ppImport is)
ppImportSpec (Hiding    _ is) = text "hiding" <+> parenList (map ppImport is)

ppImport :: Import -> Doc
ppImport (Import             _ x) = ppIdent x
ppImport (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs)
ppImport (ImportTypeAll     _ tc) = ppIdent tc <> text "(..)"

ppBlock :: [Decl a] -> Doc
ppBlock = vcat . map ppDecl

ppSepBlock :: [Decl a] -> Doc
ppSepBlock = vcat . map (\d -> text "" $+$ ppDecl d)

-- |Pretty print a declaration
ppDecl :: Decl a -> Doc
ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)
ppDecl (DataDecl _ tc tvs cs clss) =
  sep (ppTypeDeclLhs "data" tc tvs :
       map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs) ++
                   [ppDeriving clss]))
ppDecl (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs
ppDecl (NewtypeDecl _ tc tvs nc clss) =
  sep (ppTypeDeclLhs "newtype" tc tvs <+> equals :
       map indent [ppNewConstr nc, ppDeriving clss])
ppDecl (TypeDecl _ tc tvs ty) =
  sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
ppDecl (TypeSig _ fs qty) =
  list (map ppIdent fs) <+> text "::" <+> ppQualTypeExpr qty
ppDecl (FunctionDecl _ _ _ eqs) = vcat (map ppEquation eqs)
ppDecl (ExternalDecl   _ vs) = list (map ppVar vs) <+> text "external"
ppDecl (PatternDecl _ t rhs) = ppRule (ppPattern 0 t) equals rhs
ppDecl (FreeDecl       _ vs) = list (map ppVar vs) <+> text "free"
ppDecl (DefaultDecl   _ tys) =
  text "default" <+> parenList (map (ppTypeExpr 0) tys)
ppDecl (ClassDecl _ cx cls clsvar ds) =
  ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+>
    ppIf (not $ null ds) (text "where") $$
    ppIf (not $ null ds) (indent $ ppBlock ds)
ppDecl (InstanceDecl _ cx qcls inst ds) =
  ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
    ppIf (not $ null ds) (text "where") $$
    ppIf (not $ null ds) (indent $ ppBlock ds)

ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc
ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty

ppContext :: Context -> Doc
ppContext []  = empty
ppContext [c] = ppConstraint c <+> darrow
ppContext cs  = parenList (map ppConstraint cs) <+> darrow

ppConstraint :: Constraint -> Doc
ppConstraint (Constraint _ qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty

ppInstanceType :: InstanceType -> Doc
ppInstanceType = ppTypeExpr 2

ppDeriving :: [QualIdent] -> Doc
ppDeriving []     = empty
ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls
ppDeriving qclss  = text "deriving" <+> parenList (map ppQIdent qclss)

ppPrec :: Infix -> Maybe Precedence -> Doc
ppPrec fix p = pPrint fix <+> ppPrio p
  where
    ppPrio Nothing   = empty
    ppPrio (Just p') = integer p'

ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)

ppConstr :: ConstrDecl -> Doc
ppConstr (ConstrDecl     _ c tys) =
  sep [ ppIdent c <+> fsep (map (ppTypeExpr 2) tys) ]
ppConstr (ConOpDecl _ ty1 op ty2) =
  sep [ ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2 ]
ppConstr (RecordDecl _ c fs)      =
  sep [ ppIdent c <+> record (list (map ppFieldDecl fs)) ]

ppFieldDecl :: FieldDecl -> Doc
ppFieldDecl (FieldDecl _ ls ty) = list (map ppIdent ls)
                               <+> text "::" <+> ppTypeExpr 0 ty

ppNewConstr :: NewConstrDecl -> Doc
ppNewConstr (NewConstrDecl _ c ty) = sep [ppIdent c <+> ppTypeExpr 2 ty]
ppNewConstr (NewRecordDecl _ c (i,ty)) =
  sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> ppTypeExpr 0 ty)]

ppQuantifiedVars :: [Ident] -> Doc
ppQuantifiedVars tvs
  | null tvs = empty
  | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'

ppEquation :: Equation a -> Doc
ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs

ppLhs :: Lhs a -> Doc
ppLhs (FunLhs   _ f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts)
ppLhs (OpLhs _ t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2
ppLhs (ApLhs  _ lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts)

ppRule :: Doc -> Doc -> Rhs a -> Doc
ppRule lhs eq (SimpleRhs _ e ds) =
  sep [lhs <+> eq, indent (ppExpr 0 e)] $$ ppLocalDefs ds
ppRule lhs eq (GuardedRhs _ es ds) =
  sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds

ppLocalDefs :: [Decl a] -> Doc
ppLocalDefs ds
  | null ds   = empty
  | otherwise = indent (text "where" <+> ppBlock ds)

-- ---------------------------------------------------------------------------
-- Interfaces
-- ---------------------------------------------------------------------------

-- |Pretty print an interface
ppInterface :: Interface -> Doc
ppInterface (Interface m is ds)
  =  text "interface" <+> ppMIdent m <+> text "where" <+> lbrace
  $$ vcat (punctuate semi $ map ppIImportDecl is ++ map ppIDecl ds)
  $$ rbrace

ppIImportDecl :: IImportDecl -> Doc
ppIImportDecl (IImportDecl _ m) = text "import" <+> ppMIdent m

-- |Pretty print an interface declaration
ppIDecl :: IDecl -> Doc
ppIDecl (IInfixDecl   _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op
ppIDecl (HidingDataDecl _ tc k tvs) =
  text "hiding" <+> ppITypeDeclLhs "data" tc k tvs
ppIDecl (IDataDecl   _ tc k tvs cs hs) =
  sep (ppITypeDeclLhs "data" tc k tvs :
       map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)) ++
       [indent (ppHiding hs)])
ppIDecl (INewtypeDecl _ tc k tvs nc hs) =
  sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals
      , indent (ppNewConstr nc)
      , indent (ppHiding hs)
      ]
ppIDecl (ITypeDecl _ tc k tvs ty) =
  sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (ppTypeExpr 0 ty)]
ppIDecl (IFunctionDecl _ f cm a qty) =
  sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm
      , int a, text "::", ppQualTypeExpr qty ]
ppIDecl (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+>
  ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar)
ppIDecl (IClassDecl _ cx qcls k clsvar ms hs) =
  ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+>
    lbrace $$
    vcat (punctuate semi $ map (indent . ppIMethodDecl) ms) $$
    rbrace <+> ppHiding hs
ppIDecl (IInstanceDecl _ cx qcls inst impls m) =
  ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
    lbrace $$
    vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$
    rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m

ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc
ppITypeDeclLhs kw tc k tvs =
  text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)

ppIMethodDecl :: IMethodDecl -> Doc
ppIMethodDecl (IMethodDecl _ f a qty) =
  ppIdent f <+> maybePP int a <+> text "::" <+> ppQualTypeExpr qty

ppIMethodImpl :: IMethodImpl -> Doc
ppIMethodImpl (f, a) = ppIdent f <+> int a

ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc
ppQIdentWithKind tc (Just k) = parens $ ppQIdent tc <+> text "::" <+> ppKindExpr 0 k
ppQIdentWithKind tc Nothing  = ppQIdent tc

ppHiding :: [Ident] -> Doc
ppHiding hs
  | null hs   = empty
  | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs

-- ---------------------------------------------------------------------------
-- Kinds
-- ---------------------------------------------------------------------------

ppKindExpr :: Int -> KindExpr -> Doc
ppKindExpr _ Star              = char '*'
ppKindExpr p (ArrowKind k1 k2) =
  parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2)))
  where
  ppArrowKind (ArrowKind k1' k2') = ppKindExpr 1 k1' <+> rarrow : ppArrowKind k2'
  ppArrowKind k                   = [ppKindExpr 0 k]

-- ---------------------------------------------------------------------------
-- Types
-- ---------------------------------------------------------------------------

-- |Pretty print a qualified type expression
ppQualTypeExpr :: QualTypeExpr -> Doc
ppQualTypeExpr (QualTypeExpr _ cx ty) = ppContext cx <+> ppTypeExpr 0 ty

-- |Pretty print a type expression
ppTypeExpr :: Int -> TypeExpr -> Doc
ppTypeExpr _ (ConstructorType _ tc) = ppQIdent tc
ppTypeExpr p (ApplyType  _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])
  where ppApplyType (ApplyType _ ty1' ty2') tys = ppApplyType ty1' (ty2' : tys)
        ppApplyType ty tys                  =
          ppTypeExpr 1 ty <+> fsep (map (ppTypeExpr 2) tys)
ppTypeExpr _ (VariableType    _ tv) = ppIdent tv
ppTypeExpr _ (TupleType      _ tys) = parenList (map (ppTypeExpr 0) tys)
ppTypeExpr _ (ListType        _ ty) = brackets (ppTypeExpr 0 ty)
ppTypeExpr p (ArrowType  spi ty1 ty2) = parenIf (p > 0)
  (fsep (ppArrowType (ArrowType spi ty1 ty2)))
  where
  ppArrowType (ArrowType _ ty1' ty2') =
    ppTypeExpr 1 ty1' <+> rarrow : ppArrowType ty2'
  ppArrowType ty                    = [ppTypeExpr 0 ty]
ppTypeExpr _ (ParenType       _ ty) = parens (ppTypeExpr 0 ty)
ppTypeExpr p (ForallType   _ vs ty)
  | null vs   = ppTypeExpr p ty
  | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty

-- ---------------------------------------------------------------------------
-- Literals
-- ---------------------------------------------------------------------------

ppLiteral :: Literal -> Doc
ppLiteral (Char   c) = text (show c)
ppLiteral (Int    i) = integer i
ppLiteral (Float  f) = double f
ppLiteral (String s) = text (show s)

-- ---------------------------------------------------------------------------
-- Patterns
-- ---------------------------------------------------------------------------

-- |Pretty print a constructor term
ppPattern :: Int -> Pattern a -> Doc
ppPattern p (LiteralPattern _ _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)
  where isNegative (Char   _) = False
        isNegative (Int    i) = i < 0
        isNegative (Float  f) = f < 0.0
        isNegative (String _) = False
ppPattern p (NegativePattern        _ _ l) = parenIf (p > 1)
  (ppInfixOp minusId <> ppLiteral l)
ppPattern _ (VariablePattern        _ _ v) = ppIdent v
ppPattern p (ConstructorPattern  _ _ c ts) = parenIf (p > 1 && not (null ts))
  (ppQIdent c <+> fsep (map (ppPattern 2) ts))
ppPattern p (InfixPattern     _ _ t1 c t2) = parenIf (p > 0)
  (sep [ppPattern 1 t1 <+> ppQInfixOp c, indent (ppPattern 0 t2)])
ppPattern _ (ParenPattern             _ t) = parens (ppPattern 0 t)
ppPattern _ (TuplePattern            _ ts) = parenList (map (ppPattern 0) ts)
ppPattern _ (ListPattern           _ _ ts) = bracketList (map (ppPattern 0) ts)
ppPattern _ (AsPattern              _ v t) = ppIdent v <> char '@' <> ppPattern 2 t
ppPattern _ (LazyPattern              _ t) = char '~' <> ppPattern 2 t
ppPattern p (FunctionPattern     _ _ f ts) = parenIf (p > 1 && not (null ts))
  (ppQIdent f <+> fsep (map (ppPattern 2) ts))
ppPattern p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0)
  (sep [ppPattern 1 t1 <+> ppQInfixOp f, indent (ppPattern 0 t2)])
ppPattern p (RecordPattern       _ _ c fs) = parenIf (p > 1)
  (ppQIdent c <+> record (list (map ppFieldPatt fs)))

-- |Pretty print a record field pattern
ppFieldPatt :: Field (Pattern a) -> Doc
ppFieldPatt (Field _ l t) = ppQIdent l <+> equals <+> ppPattern 0 t

-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------

ppCondExpr :: Doc -> CondExpr a -> Doc
ppCondExpr eq (CondExpr _ g e) =
  vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]

-- |Pretty print an expression
ppExpr :: Int -> Expression a -> Doc
ppExpr _ (Literal        _ _ l) = ppLiteral l
ppExpr _ (Variable       _ _ v) = ppQIdent v
ppExpr _ (Constructor    _ _ c) = ppQIdent c
ppExpr _ (Paren            _ e) = parens (ppExpr 0 e)
ppExpr p (Typed        _ e qty) =
  parenIf (p > 0) (ppExpr 0 e <+> text "::" <+> ppQualTypeExpr qty)
ppExpr _ (Tuple           _ es) = parenList (map (ppExpr 0) es)
ppExpr _ (List          _ _ es) = bracketList (map (ppExpr 0) es)
ppExpr _ (ListCompr     _ e qs) =
  brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))
ppExpr _ (EnumFrom              _ e) = brackets (ppExpr 0 e <+> text "..")
ppExpr _ (EnumFromThen      _ e1 e2) =
  brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")
ppExpr _ (EnumFromTo        _ e1 e2) =
  brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)
ppExpr _ (EnumFromThenTo _ e1 e2 e3) =
  brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
              <+> text ".." <+> ppExpr 0 e3)
ppExpr p (UnaryMinus          _ e) =
  parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e)
ppExpr p (Apply           _ e1 e2) =
  parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
ppExpr p (InfixApply   _ e1 op e2) =
  parenIf (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),
                         indent (ppExpr 1 e2)])
ppExpr _ (LeftSection      _ e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))
ppExpr _ (RightSection     _ op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)
ppExpr p (Lambda            _ t e) = parenIf (p > 0)
  (sep [backsl <> fsep (map (ppPattern 2) t) <+> rarrow, indent (ppExpr 0 e)])
ppExpr p (Let              _ ds e) = parenIf (p > 0)
          (sep [text "let" <+> ppBlock ds, text "in" <+> ppExpr 0 e])
ppExpr p (Do              _ sts e) = parenIf (p > 0)
          (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))
ppExpr p (IfThenElse   _ e1 e2 e3) = parenIf (p > 0)
           (text "if" <+>
            sep [ppExpr 0 e1,
                 text "then" <+> ppExpr 0 e2,
                 text "else" <+> ppExpr 0 e3])
ppExpr p (Case      _ ct e alts) = parenIf (p > 0)
           (ppCaseType ct <+> ppExpr 0 e <+> text "of" $$
            indent (vcat (map ppAlt alts)))
ppExpr p (Record     _ _ c fs) = parenIf (p > 0)
  (ppQIdent c <+> record (list (map ppFieldExpr fs)))
ppExpr _ (RecordUpdate _ e fs) =
  ppExpr 0 e <+> record (list (map ppFieldExpr fs))

-- |Pretty print a statement
ppStmt :: Statement a -> Doc
ppStmt (StmtExpr   _ e) = ppExpr 0 e
ppStmt (StmtBind _ t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)]
ppStmt (StmtDecl  _ ds) = text "let" <+> ppBlock ds

ppCaseType :: CaseType -> Doc
ppCaseType Rigid = text "case"
ppCaseType Flex  = text "fcase"

-- |Pretty print an alternative in a case expression
ppAlt :: Alt a -> Doc
ppAlt (Alt _ t rhs) = ppRule (ppPattern 0 t) rarrow rhs

-- |Pretty print a free variable
ppVar :: Var a -> Doc
ppVar (Var _ ident) = ppIdent ident

-- |Pretty print a record field expression (Haskell syntax)
ppFieldExpr :: Field (Expression a) -> Doc
ppFieldExpr (Field _ l e) = ppQIdent l <+> equals <+> ppExpr 0 e

-- |Pretty print an operator
ppOp :: InfixOp a -> Doc
ppOp (InfixOp     _ op) = ppQInfixOp op
ppOp (InfixConstr _ op) = ppQInfixOp op

-- ---------------------------------------------------------------------------
-- Names
-- ---------------------------------------------------------------------------

-- |Pretty print an identifier
ppIdent :: Ident -> Doc
ppIdent x = parenIf (isInfixOp x) (text (idName x))

ppQIdent :: QualIdent -> Doc
ppQIdent x = parenIf (isQInfixOp x) (text (qualName x))

ppInfixOp :: Ident -> Doc
ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x))

ppQInfixOp :: QualIdent -> Doc
ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x))

ppMIdent :: ModuleIdent -> Doc
ppMIdent m = text (moduleName m)

-- ---------------------------------------------------------------------------
-- Print printing utilities
-- ---------------------------------------------------------------------------

indent :: Doc -> Doc
indent = nest 2

parenList :: [Doc] -> Doc
parenList = parens . list

record :: Doc -> Doc
record doc | isEmpty doc = braces empty
           | otherwise   = braces $ space <> doc <> space

bracketList :: [Doc] -> Doc
bracketList = brackets . list
