{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Mode.Haskell.Dollarify
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable

module Yi.Mode.Haskell.Dollarify where

import           Control.Applicative
import           Control.Monad
import           Data.Function (on)
import           Data.List (sortBy)
import           Data.Maybe (fromMaybe)
import           Data.Monoid
import           Data.Text ()
import           Yi.Buffer hiding (Block)
import           Yi.Debug
import           Yi.Lexer.Alex (posnOfs, Tok(..))
import           Yi.Lexer.Haskell (isComment, TT, Token(..))
import qualified Yi.Rope as R
import           Yi.String
import qualified Yi.Syntax.Haskell as H (Tree, Exp(..))
import           Yi.Syntax.Paren (Expr, Tree(..))
import           Yi.Syntax.Tree (getAllSubTrees, getFirstOffset,
                                 getLastOffset, getLastPath)

dollarify :: Tree TT -> BufferM ()
dollarify t = maybe (return ()) dollarifyWithin . selectedTree [t] =<< getSelectRegionB

dollarifyWithin :: Tree TT -> BufferM ()
dollarifyWithin = trace . ("dollarifyWithin: " <>) . showT <*> runQ . (dollarifyTop =<<) . getAllSubTrees

data QueuedUpdate = QueuedUpdate { qUpdatePoint :: Point
                                 , qInsert      :: R.YiString
                                 , qDelete      :: Int
                                 } deriving (Eq, Ord, Show)

runQ :: [QueuedUpdate] -> BufferM ()
runQ = trace . ("runQ: " <>) . showT <*> mapM_ run1Q . sortBy (flip compare)
    where
       run1Q :: QueuedUpdate -> BufferM ()
       run1Q (QueuedUpdate { qUpdatePoint = p, qInsert = i, qDelete = d })
              = do deleteNAt Forward d p
                   unless (R.null i) $ insertNAt i p

openParen, closeParen :: Token
openParen = Special '('
closeParen = Special ')'

isNormalParen :: Tree TT -> Bool
isNormalParen (Paren t1 xs t2) =
  tokT t1 == openParen && tokT t2 == closeParen && not (any isTuple xs)
isNormalParen _               = False

isTuple ::Tree TT -> Bool
isTuple (Atom t) = tokT t == Special ','
isTuple _ = False

-- Assumes length of token is one character
queueDelete :: TT -> QueuedUpdate
queueDelete = queueReplaceWith ""

-- Assumes length of token is one character
queueReplaceWith :: R.YiString -> TT -> QueuedUpdate
queueReplaceWith s t = QueuedUpdate { qUpdatePoint = posnOfs $ tokPosn t
                                    , qInsert = s
                                    , qDelete = 1
                                    }

-- Only strips comments from the top level
stripComments :: Expr TT -> Expr TT
stripComments = filter $ \t -> case t of { (Atom x) -> not (isComment $ tokT x); _ -> True }

dollarifyTop :: Tree TT -> [QueuedUpdate]
dollarifyTop p@(Paren t1 e t2)
   | isNormalParen p = case stripComments e of
       [Paren{}] -> [queueDelete t2, queueDelete t1]
       e'        -> dollarifyExpr e'
dollarifyTop (Block blk) = dollarifyExpr . stripComments =<< [x | Expr x <- blk]
dollarifyTop _ = []

-- Expression must not contain comments
dollarifyExpr :: Expr TT -> [QueuedUpdate]
dollarifyExpr e@(_:_)
    | p@(Paren t e2 t2) <- last e
    , isNormalParen p
    , all isSimple e
    = let dollarifyLoop :: Expr TT -> [QueuedUpdate]
          dollarifyLoop [] = []
          dollarifyLoop e3@[Paren{}] = dollarifyExpr e3
          dollarifyLoop e3 = if isCollapsible e3 then [queueDelete t2, queueReplaceWith "$ " t] else []
          in dollarifyLoop $ stripComments e2
dollarifyExpr _ = []

isSimple :: Tree TT -> Bool
isSimple (Paren{}) = True
isSimple (Block{}) = False
isSimple (Atom t)  = tokT t `elem` [Number, CharTok, StringTok, VarIdent, ConsIdent]
isSimple _         = False

-- Expression must not contain comments
isCollapsible :: Expr TT -> Bool
isCollapsible = ((&&) `on` isSimple) . head <*> last

selectedTree :: Expr TT -> Region -> Maybe (Tree TT)
selectedTree e r = findLargestWithin r <$> getLastPath e (regionLast r)

-- List must be non-empty
findLargestWithin :: Region -> [Tree TT] -> Tree TT
findLargestWithin r = fromMaybe . head <*> safeLast . takeWhile (within r)

within :: Region -> Tree TT -> Bool
within r t = includedRegion ((mkRegion . getFirstOffset <*> getLastOffset) t) r

safeLast :: [a] -> Maybe a
safeLast [] = Nothing
safeLast s  = return $ last s

-- Here follows code for the precise haskell mode

dollarifyP :: H.Tree TT -> BufferM ()
dollarifyP e = maybe (return ()) dollarifyWithinP . selectedTreeP [e] =<< getSelectRegionB

dollarifyWithinP :: H.Exp TT -> BufferM ()
dollarifyWithinP = trace . ("dollarifyWithin: " <>) . showT <*> runQ . (dollarifyTopP =<<) . getAllSubTrees

isNormalParenP :: H.Exp TT -> Bool
isNormalParenP (H.Paren (H.PAtom r _) xs (H.PAtom r' _)) =
  tokT r == openParen && tokT r' == closeParen && not (any isTupleP xs)
isNormalParenP _               = False

isTupleP :: H.Exp TT -> Bool
isTupleP (H.PAtom t _) = tokT t == Special ','
isTupleP _ = False

-- Only strips comments from the top level
stripCommentsP :: [H.Exp TT] -> [H.Exp TT]
stripCommentsP = filter $ \t -> case t of { (H.PAtom x _) -> not (isComment $ tokT x); _ -> True }

dollarifyTopP :: H.Exp TT -> [QueuedUpdate]
dollarifyTopP p@(H.Paren (H.PAtom t1 _) e (H.PAtom t2 _))
   | isNormalParenP p = case stripCommentsP e of
       [H.Paren{}] -> [queueDelete t2, queueDelete t1]
       e'          -> dollarifyExprP e'
dollarifyTopP (H.Block bList) = dollarifyExprP . stripCommentsP $ bList
dollarifyTopP _ = []

-- Expression must not contain comments
dollarifyExprP :: [H.Exp TT] -> [QueuedUpdate]
dollarifyExprP e@(_:_)
    | p@(H.Paren (H.PAtom t _) e2 (H.PAtom t2 _)) <- last e
    , isNormalParenP p
    , all isSimpleP e
    = let dollarifyLoop :: [H.Exp TT] -> [QueuedUpdate]
          dollarifyLoop [] = []
          dollarifyLoop e3@[H.Paren{}] = dollarifyExprP e3
          dollarifyLoop e3 = if isCollapsibleP e3 then [queueDelete t2, queueReplaceWith "$ " t] else []
          in dollarifyLoop $ stripCommentsP e2
dollarifyExprP _ = []

isSimpleP :: H.Exp TT -> Bool
isSimpleP (H.Paren{})   = True
isSimpleP (H.Block{})   = False
isSimpleP (H.PAtom t _) = tokT t `elem` [Number, CharTok, StringTok, VarIdent, ConsIdent]
isSimpleP _             = False

-- Expression must not contain comments
isCollapsibleP :: [H.Exp TT] -> Bool
isCollapsibleP = ((&&) `on` isSimpleP) . head <*> last

selectedTreeP :: [H.Exp TT] -> Region -> Maybe (H.Exp TT)
selectedTreeP e r = findLargestWithinP r <$> getLastPath e (regionLast r)

-- List must be non-empty
findLargestWithinP :: Region -> [H.Exp TT] -> H.Exp TT
findLargestWithinP r = fromMaybe . head <*> safeLast . takeWhile (withinP r)

withinP :: Region -> H.Exp TT -> Bool
withinP r t = includedRegion ((mkRegion . getFirstOffset <*> getLastOffset) t) r

safeLastP :: [a] -> Maybe a
safeLastP [] = Nothing
safeLastP s  = return $ last s