content: {-# LANGUAGE UndecidableInstances #-}
  
  -- | Pretty printing for Discus modules and expressions.
  module DDC.Source.Discus.Pretty
          ( module DDC.Core.Codec.Text.Pretty
          , module DDC.Data.Pretty
          , PrettyLanguage)
  where
  import DDC.Source.Discus.Module
  import DDC.Source.Discus.Exp
  import DDC.Source.Discus.Exp.Type.Pretty
  import DDC.Core.Codec.Text.Pretty
  import DDC.Data.Pretty
  
  
  ---------------------------------------------------------------------------------------------------
  type PrettyLanguage a
   =      ( Pretty a
          , Pretty (DaCon DaConBound (GType a)))
  
  
  instance Pretty DaConBind where
   ppr (DaConBindName tt)   = text tt
  
  
  instance Pretty DaConBound where
   ppr uu
    = case uu of
          DaConBoundName tt -> text tt
          DaConBoundLit  pl -> ppr  pl
  
  
  -- Bind -------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GXBindVarMT l) where
   ppr (XBindVarMT b mt)
    = case mt of
          Nothing         -> ppr b
          Just  _t        -> ppr b
  
  
  -- Type -------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GType l) where
   pprPrec d tt
    = case tt of
          TAnnot _ t      -> pprPrec d t
          TCon tc         -> ppr tc
          TVar bv         -> ppr bv
  
          TAbs bv k t
           -> text "λ" <> ppr bv <> text ":" %% ppr k <> text "." %% ppr t
  
          TApp (TApp (TCon TyConFunExplicit) t1) t2
           -> pprParen' (d > 5)
           $  pprPrec 6  t1 %% text "->" %% pprPrec 5 t2
  
          TApp (TApp (TCon TyConFunImplicit) t1) t2
           -> pprParen' (d > 5)
           $  pprPrec 6  t1 %% text "~>" %% pprPrec 5 t2
  
          TApp t1 t2
           -> pprParen' (d > 10)
           $  pprPrec 10 t1 %% pprPrec 11 t2
  
          TRow r
           -> braces
            $ hcat $ punctuate (string ", ")
                   [ text (nameOfLabel l) % string ": " % pprRawT t | (l, t) <- r ]
  
          TTuple r
           -> parens
            $ hcat $ punctuate (string ", ")
                   [ text (nameOfLabel l) % string ": " % pprRawT t | (l, t) <- r ]
  
          TRecord r
           -> brackets
            $ hcat $ punctuate (string ", ")
                   [ text (nameOfLabel l) % string ": " % pprRawT t | (l, t) <- r ]
  
          TVariant r
           -> angles
            $ hcat $ punctuate (string ", ")
                   [ text (nameOfLabel l) % string ": " % pprRawT t | (l, t) <- r ]
  
  
  instance PrettyLanguage l => Pretty (GTyCon l) where
   ppr tc
    = pprRawC tc
  
  
  -- Module -----------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (Module l) where
   ppr Module
          { moduleName            = name
          , moduleExportTypes     = _exportedTypes
          , moduleExportValues    = _exportedValues
          , moduleImportModules   = importedModules
          , moduleImportTypes     = importedTypes
          , moduleImportValues    = importedValues
          , moduleTops            = tops }
    = vcat
    [ text "module"
          %% ppr name
          <>  sImportedModules
          <>  sImportedTypes
          <>  sImportedValues
          <>   (if null importedModules && null importedTypes && null importedValues
                  then space <> text "where"
                  else text "where")
    , vcat $ map ppr tops]
  
    where sImportedModules
           | null importedModules = mempty
           | otherwise
           = line
           <> (vcat $ map pprImportModule importedModules)
           <> line
  
          sImportedTypes
           | null importedTypes   = mempty
           | otherwise
           = line
           <> (vcat $ map pprImportType importedTypes)
           <> line
  
          sImportedValues
           | null importedValues  = mempty
           | otherwise
           = (vcat $ map (pprImportValue . snd) importedValues)
           <> line
  
          pprImportModule mn
           = text "import module" %% ppr mn
  
  -- Top --------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (Top l) where
   ppr (TopClause _ c)
    =  ppr c
    <> semi <> line
  
   ppr (TopData _ (DataDef name params ctors))
    = vcat
    [ text "data"
          %% hsep ( ppr name
                   : map pprParam params)
          %% text "where"
          %% lbrace
  
    , indent 8
          $ vcat [ ppr (dataCtorName ctor)
                  %% text ":"
                  %% (hsep   $ punctuate (text " ->")
                                  $ (  map (pprPrec 6) (dataCtorFieldTypes ctor)
                                    ++ [ ppr           (dataCtorResultType ctor)]))
                  <> semi
                          | ctor       <- ctors ]
    , rbrace <> semi
    , mempty ]
  
   ppr (TopType _ b t)
    =  text "type" %% ppr b %% text "=" %% ppr t
    <> semi
    <> line
  
  pprParam (b, t)
   = parens $ ppr b <> text ":" %% ppr t
  
  
  -- Exp --------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GExp l) where
   pprPrec d xx
    = {-# SCC "ppr[Exp]" #-}
      case xx of
          XAnnot _ x      -> pprPrec d x
          XPrim p         -> ppr p
          XVar  u         -> ppr u
          XCon  dc        -> ppr dc
  
          XAbs  (MType b _) xBody
           -> pprParen' (d > 1)
                   $   text "/\\" <>  ppr b <> text "."
                   <>  (if      isXAbs    xBody then line <> space
                        else if isSimpleX xBody then space
                        else    line)
                   <>  ppr xBody
  
          XAbs (MTerm b _) xBody
           -> pprParen' (d > 1)
                   $  text "\\" <> ppr b <> text "."
                   <> breakWhen (not $ isSimpleX xBody)
                   <> ppr xBody
  
          XAbs (MImplicit b _) xBody
           -> pprParen' (d > 1)
                   $  text "\\{" <> ppr b <> text "}."
                   <> breakWhen (not $ isSimpleX xBody)
                   <> ppr xBody
  
          XApp x1 r2
           -> pprParen' (d > 10)
           $  pprPrec 10 x1 %% nest 4 (pprPrec 11 r2)
  
          XLet lts x
           ->  pprParen' (d > 2)
           $   vcat [ ppr lts %% text "in", ppr x]
  
          XCase x alts
           -> pprParen' (d > 2)
           $  (nest 2 $ text "case" %% ppr x %% text "of" %% lbrace <> line
                  <> (vcat $ punctuate semi $ map ppr alts))
           <> line
           <> rbrace
  
          XCast CastBox x
           -> pprParen' (d > 2)
           $  vcat [ text "box", ppr x]
  
          XCast CastRun x
           -> pprParen' (d > 2)
           $  text "run"  %% ppr x
  
          XCast cc x
           ->  pprParen' (d > 2)
           $   vcat [ ppr cc %% text "in", ppr x]
  
          XDefix    _ xs
           -> text "[" <> text "DEFIX|" %% hsep (map (pprPrec 11) xs) %% text "]"
  
          XInfixOp  _ str
           -> parens $ text "INFIXOP"  %% text "\"" % string str % text "\""
  
          XInfixVar _ str
           -> parens $ text "INFIXVAR" %% text "\"" % string str % text "\""
  
          XMatch _ alts xDefault
           -> pprParen' (d > 2)
           $  (nest 2 $ text "match" %% lbrace <> line
                  <> (vcat $ punctuate (semi <> line) $ map ppr alts))
           <> line
           <> rbrace
           %% text "else" %% pprPrec 10 xDefault
  
          XWhere _ x cls
           ->  pprParen' (d > 2)
           $   ppr x
           %% line
           <>  (text "where"
                  %% text "{" <> line
                  <>  (nest 4 $ vcat $ map ppr cls)
                  <>  line
                  <>  text "}")
  
          XAbsPat _ ps p mt xBody
           -> pprParen' (d > 1)
           $  text "\\"
                  <> (case ps of
                          MSType          -> text "["
                          MSTerm          -> text "("
                          MSImplicit      -> text "{")
                  <> pprPrec 2 p
                  <> (case mt of
                          Just t  -> text ": " <> ppr t
                          Nothing -> mempty)
                  <> (case ps of
                          MSType          -> text "]"
                          MSTerm          -> text ")"
                          MSImplicit      -> text "}")
                  <> text "."
           <> breakWhen (not $ isSimpleX xBody)
           <> ppr xBody
  
          XLamCase _ alts
           -> pprParen' (d > 1)
           $  text "λcase." <> lbrace <> line
                  <> (vcat $ punctuate semi $ map ppr alts)
           <> line <> rbrace
  
          XTuple _ r
           -> parens $ hcat $ punctuate (text ", ")
                  [ ppr l % text " = " % ppr x | (l, x) <- r ]
  
          XRecord _ r
           -> brackets $ hcat $ punctuate (text ", ")
                  [ ppr l % text " = " % ppr x | (l, x) <- r ]
  
          XVariant _ l x
           -> text "`" % ppr l %% pprPrec 11 x
  
          XArray _ xs
           -> brackets $ hcat $ punctuate (text ", ") $ map ppr xs
  
  
  -- Arg --------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GArg l) where
   ppr rr
    = case rr of
          RType t
           -> (text "[" <> ppr t <> text "]")
  
          RWitness w
           -> (text "<" <> ppr w <> text ">")
  
          RImplicit x
           -> (text "{" <> ppr x <> text "}")
  
          RTerm x
           -> pprPrec 11 x
  
  
  -- Lets -------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GLets l) where
   ppr lts
    = case lts of
          LLet b x
           -> text "let"
                   %% align (  ppr b
                             <> nest 2 ( breakWhen (not $ isSimpleX x)
                                       <> text "=" %% align (ppr x)))
          LRec bxs
           -> let pprLetRecBind (b, x)
                   =   ppr b
                   <>  nest 2 (  breakWhen (not $ isSimpleX x)
                              <> text "=" %% align (ppr x))
  
             in vcat
                  [ nest 2 $ text "rec"
                    %% lbrace
                    <>  (  line
                        <> (vcat $ punctuate (semi <> line)
                                 $ map pprLetRecBind bxs))
                  , rbrace]
  
          LPrivate bs (CapsList [])
           -> text "private"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LPrivate bs (CapsList bsWit)
           -> text "private"
                  %% (hcat $ punctuate space (map ppr bs))
                  %% text "with"
                  %% braces (cat $ punctuate (text "; ") $ map ppr bsWit)
  
          LPrivate bs CapsMutable
           -> text "mutable"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LPrivate bs CapsConstant
           -> text "constant"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LExtend bs parent (CapsList [])
           -> text "extend"
                  %% ppr parent
                  %% text "using"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LExtend bs parent (CapsList bsWit)
           -> text "extend"
                  %% ppr parent
                  %% text "using"
                  %% (hcat $ punctuate space (map ppr bs))
                  %% text "with"
                  %% braces (cat $ punctuate (text "; ") $ map ppr bsWit)
  
          LExtend bs parent CapsMutable
           -> text "extend"
                  %% ppr parent
                  %% text "with mutable"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LExtend bs parent CapsConstant
           -> text "extend"
                  %% ppr parent
                  %% text "with constant"
                  %% (hcat $ punctuate space (map ppr bs))
  
          LGroup bRec cs
           ->   (if bRec then text "recs" else text "lets")
                  %% nest 2 (lbrace
                                  <> line
                                  <> (vcat $ map ppr cs)
                                  <> line <> rbrace)
  
  
  -- Clause -----------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GClause l) where
   ppr (SSig _ b t)
    = ppr b %% text ":" %% ppr t
  
   ppr (SLet _ b ps [GExp x])
    = ppr b       %% hsep (map (pprPrec 10) ps)
                  <>  nest 2 ( breakWhen (not $ isSimpleX x)
                             <> text "=" %% align (ppr x))
  
   ppr (SLet _ b ps gxs)
    = ppr b       %% hsep (map (pprPrec 10) ps)
                  <>  nest 2 (line <> vcat (map (pprGuardedExp "=") gxs))
  
  
  -- Param ------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GParam l) where
   pprPrec _d (MType    b Nothing)
    = text "[" <> ppr b <> text "]"
  
   pprPrec _d (MType    b (Just t))
    = text "[" <> ppr b <> text ":" %% ppr t <> text "]"
  
   pprPrec d  (MTerm    p Nothing)
    = pprPrec d p
  
   pprPrec _  (MTerm    p (Just t))
    = parens $ pprPrec 0 p <> text ":" %% ppr t
  
   pprPrec _d (MImplicit b Nothing)
    = text "{" <> ppr b <> text "}"
  
   pprPrec _d (MImplicit b (Just t))
    = text "{" <> ppr b <> text ":" %% ppr t <> text "}"
  
  
  -- Pat --------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GPat l) where
   pprPrec d pp
    = case pp of
          PDefault        -> text "_"
          PAt   b p       -> ppr b <> text "@" <> ppr p
          PVar  b         -> ppr b
  
          PData u []      -> ppr u
  
          PData u ps
           -> pprParen' (d > 1)
           $  ppr u %% sep (map (pprPrec 2) ps)
  
  
  -- GuardedExp -------------------------------------------------------------------------------------
  pprGuardedExp :: PrettyLanguage l => String -> GGuardedExp l -> Doc
  pprGuardedExp sTerm gx
    = pprGs "|" gx
    where
          pprGs _c (GExp x)
           = string sTerm %% ppr x
  
          pprGs c (GGuard g gs)
           = pprG c g <> line <> pprGs "," gs
  
          pprG  c (GPat p x)
           = text c %% ppr p  %% text "<-" %% ppr x
  
          pprG  c (GPred x)
           = text c %% ppr x
  
          pprG  c GDefault
           = text c %% text "otherwise"
  
  
  -- Guard ------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GGuard l) where
   ppr gg
    = case gg of
          GPat p w
           -> ppr p %% text "<-" %% ppr w
  
          GPred p
           -> ppr p
  
          GDefault
           -> text "otherwise"
  
  
  -- AltCase ----------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GAltCase l) where
   ppr (AAltCase p gxs)
    =  ppr p <> nest 2 (line <> vcat (map (pprGuardedExp "->") gxs))
  
  
  -- AltMatch ---------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GAltMatch l) where
   ppr (AAltMatch gs)
    = pprGuardedExp "=" gs
  
  
  -- Cast -------------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GCast l) where
   ppr cc
    = case cc of
          CastWeakenEffect  eff -> text "weakeff" %% brackets (ppr eff)
          CastBox         -> text "box"
          CastRun         -> text "run"
  
  
  -- Witness ----------------------------------------------------------------------------------------
  instance PrettyLanguage l => Pretty (GWitness l) where
   pprPrec d ww
    = case ww of
          WAnnot _ w      -> ppr w
          WVar   n        -> ppr n
          WCon   wc       -> ppr wc
          WApp   w1 w2    -> pprParen (d > 10) (ppr w1 %% pprPrec 11 w2)
          WType  t        -> text "[" <> ppr t <> text "]"
  
  
  instance PrettyLanguage l => Pretty (GWiCon l) where
   ppr wc
    = case wc of
          WiConBound   u  _ -> ppr u
  
  
  instance (Eq n, Pretty n) => Pretty (DaCon n t) where
   ppr dc
    = case dc of
          DaConUnit       -> text "()"
  
          DaConRecord ns
           -> text "("
           <> (hcat $ punctuate (text ",") $ map text ns)
           <> text ")#"
  
          DaConPrim n     -> ppr n
          DaConBound dcb  -> ppr dcb
  
  
  -- Utils ------------------------------------------------------------------------------------------
  breakWhen :: Bool -> Doc
  breakWhen True   = line
  breakWhen False  = space
  
  
  isSimpleX :: GExp l -> Bool
  isSimpleX xx
   = case xx of
          XAnnot _ x              -> isSimpleX x
          XVar{}                  -> True
          XCon{}                  -> True
          XApp x1 (RTerm x2)      -> isSimpleX x1 && isAtomX x2
          XApp x1 _               -> isSimpleX x1
          _                       -> False
  
  
  parens' :: Doc -> Doc
  parens' d = lparen <> nest 1 d <> rparen
  
  
  -- | Wrap a `Doc` in parens if the predicate is true.
  pprParen' :: Bool -> Doc -> Doc
  pprParen' b c
   = if b then parens' c
          else c
  
  