{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE FlexibleContexts #-}

-- -- -- ghc options

-- -- {-# OPTIONS_GHC -Wall #-}
-- -- {-# OPTIONS_GHC -fno-warn-unused-matches #-}
-- -- {-# OPTIONS_GHC -fno-warn-name-shadowing #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- -- {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-- -- {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-- -- {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-- -- {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-- -- -- {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}


-- -- -- for the doctests:
-- -- -- {-# OPTIONS_GHC -fno-warn-unused-imports #-}



-- -- {-# LANGUAGE CPP #-}
-- -- {-# OPTIONS_GHC -cpp -DPiForallInstalled #-}





{-|

Copyright :  (c) Andreas Reuleaux  2015 - 2018
License   :  BSD2
Maintainer:  Andreas Reuleaux <rx@a-rx.info>
Stability :  experimental
Portability: non-portable


pretty printing for Pire's token trees

 -}







module PrettyTT where




-- import Syntax (Eps (..), Expr (..), Annot ())

import TT




import Bound


-- import Control.Monad.Reader.Class


import Data.Text.Prettyprint.Doc


-- import PrettyBasic

import PrettyCommon

-- import Data.Text (Text, unpack, pack)
import Data.Text (Text, pack)

import Control.Monad.Identity

-- setOf
import Data.Set.Lens

import Data.Set (notMember)


import Utils (names)

 {-
  cf https://github.com/ermine-language/ermine/blob/master/src/Ermine/Console/Command.hs
  
  
  pt tm = prettyExpr_
                tm names' (-1) (error "TODO: prettyAnn") (pure.pure.text.unpack)
          >>= sayLn
       where names' = filter ((`notMember` setOf traverse tm).pack) names
  -}




prettyTT_ :: (Applicative f)
             => (TT t a) -> [String] -> Int -> (t -> Int -> f (Doc ann)) -> (a -> Int -> f (Doc ann)) -> f (Doc ann)
prettyTT_ (Id v) _ prec _ ka = ka v prec
prettyTT_ (Binder v) _ prec kt _ = kt v prec
prettyTT_ (Ws v) _ prec kt _ = kt v prec
prettyTT_ (Token v) _ prec kt _ = kt v prec
prettyTT_ (NatLit v) _ prec kt _ = kt v prec
prettyTT_ None _ _ _ _ = pure emptyDoc
prettyTT_ (Pair left right) vars _ kt ka = (\df dx -> df <> dx) <$> prettyTT_ left vars 10 kt ka <*> prettyTT_ right vars 11 kt ka
-- -- prettyTT_ (Node ls) vars prec kt ka = lsep <$> traverse (\x -> prettyTT_ x vars 10 kt ka) ls
-- --   where lsep [] = emptyDoc ; lsep l = space <> hsep l
prettyTT_ (Node ls) vars _ kt ka = hcat <$> traverse (\x -> prettyTT_ x vars 10 kt ka) ls

prettyTT_ (Invisible _) _ _ _ _ = pure emptyDoc

prettyTT_ (Abstract1 p (Scope e)) vars prec kt ka = h <$> prettyTT_ e vars' (-1) kt ka'
  where
    vars' = vars
    -- h bd = parensIf (prec >= 0) $ text "\\" <> text "." <+> bd
    h bd = bd
    ka' (B _) _   = kt p prec
    ka' (F t) prc = prettyTT_ t vars' prc kt ka

prettyTT_ (Abstract ns (Scope e)) vars prec kt ka = h <$> prettyTT_ e vars' (-1) kt ka'
  where
    vars' = vars
    -- h bd = parensIf (prec >= 0) $ text "\\" <> text "." <+> bd
    h bd = bd
    ka' (B b) _   = kt (ns !! b) prec
    ka' (F t) prc = prettyTT_ t vars' prc kt ka



instance PrettyAnn (TT Text Text) where
  prettyAnn tt = prettyTT_ (tt) names' (-1) (pure . pure . pretty) (pure . pure . pretty)
    where names' = filter ((`notMember` setOf traverse tt).pack) names

instance PrettyAnn (TT String String) where
  prettyAnn tt = prettyTT_ (tt) names' (-1) (pure . pure . pretty) (pure . pure . pretty)
    where names' = filter (`notMember` setOf traverse tt) names




instance Pretty (TT Text Text) where
  pretty tt = runIdentity $ prettyTT_ (tt) names' (-1) (pure . pure . pretty) (pure . pure . pretty)
    where names' = filter ((`notMember` setOf traverse tt).pack) names


instance Pretty (TT String String) where
  pretty tt = runIdentity $ prettyTT_ (tt) names' (-1) (pure . pure . pretty) (pure . pure . pretty)
    where names' = filter ((`notMember` setOf traverse tt)) names