{-# options_ghc -fno-warn-type-defaults #-}

--------------------------------------------------------------------
-- |
-- Copyright :  (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2014
-- License   :  BSD2
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
-- General-purpose utilities for pretty printing.
--------------------------------------------------------------------

module Coda.Console.Pretty
  ( names
  , parensIf
  , hyph
  , prePunctuate
  , prePunctuate'
  , block
  , say
  , sayLn
--  , chooseNames
  ) where

import Control.Monad.IO.Class
import Control.Lens
import Data.Monoid -- Semigroup
import Data.Maybe (fromMaybe)
import Numeric.Lens
import System.IO
import Text.Hyphenation
import Text.PrettyPrint.ANSI.Leijen hiding ((<>))

-- | This is an infinitely large free variable supply you can trim your used variables out of.
names :: [String]
names = map pure az
    ++ [ i : review (base 36) j | j <- [1..], i <- az ] where
  az = ['a'..'z']

-- | Pretty print parentheses
parensIf :: Bool -> Doc -> Doc
parensIf True  = parens
parensIf False = id

-- | Hyphenate a word using standard TeX-style 'english_US' hyphenation.
hyph :: String -> Doc
hyph t = column $ \k -> columns $ \mn ->
  let n = fromMaybe 80 mn
      (pr,sf) = bimap (fmap fst) (fmap fst) $ span (\ (_,d) -> k + d < n) $ zip xs ls
      ls = tail $ scanl (\a b -> a + length b) 0 xs
      xs = hyphenate english_US t
  in if null pr
     then text (concat sf)
     else if null sf
          then text (concat pr)
          else vsep [text (concat pr) <> char '-', text (concat sf)]

prePunctuate :: Doc -> [Doc] -> [Doc]
prePunctuate _ [    ] = []
prePunctuate p (d:ds) = d : map (p <+>) ds

prePunctuate' :: Doc -> Doc -> [Doc] -> [Doc]
prePunctuate' _  _ [    ] = []
prePunctuate' fp p (d:ds) = (fp <+> d) : map (p <+>) ds

-- | Format a layout block in explicit style.
block :: [Doc] -> Doc
block [    ] = text "{}"
block (d:ds) = sep (lbrace <+> d : map (semi <+>) ds) <> line <> rbrace

-- | Pretty print to 'stdout'
say :: MonadIO m => Doc -> m ()
say = liftIO . displayIO stdout . renderPretty 0.8 80 -- TODO: options

-- | Pretty print to 'stdout' with a 'linebreak' after.
sayLn :: MonadIO m => Doc -> m ()
sayLn d = say (d <> linebreak)

{-
chooseNames :: (String -> Bool) -> [Hint] -> [String] -> ([String], [String])
chooseNames p ahs = go p ahs . filter (\n -> n `notElem` avoid && not (p n))
 where
 avoid = [ unpack h | Just h <- ahs ]

 go _     [] supply = ([], supply)
 go taken (Nothing : hs) (n:supply) = (n:) `first` go taken hs supply
 go taken (Just h  : hs) supply@(n:ns)
   | taken h'  = (n:) `first` go taken hs ns
   | otherwise = (h':) `first` go (\x -> x == h' || taken x) hs supply
  where h' = unpack h
 go _ _ _ = error "PANIC: chooseNames: ran out of names"
-}