-- {-# LANGUAGE DeriveFunctor #-}
-- {-# LANGUAGE DeriveFoldable #-}
-- {-# LANGUAGE DeriveTraversable #-}
-- {-# LANGUAGE DeriveGeneric #-}

-- {-# LANGUAGE BangPatterns #-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE CPP #-}

-- {-# OPTIONS_GHC -cpp -DPiForallInstalled #-}

-- {-# LANGUAGE TemplateHaskell #-}
-- {-# LANGUAGE RecordWildCards #-}




{-|
 Copyright :  (c) Andreas Reuleaux 2015 - 2018
 License   :  BSD2
 Maintainer:  Andreas Reuleaux <rx@a-rx.info>
 Stability :  experimental
 Portability: non-portable
 
decorate the syntax tree with exact position information, 
used subsequently to calculate token ranges, 
and allow for navigation in the white space aware syntax tree
(in the token tree @'TT'@) by line column information
 -}



module Decorate
       (

         module Decorate

-- , module Control.Exception
-- , module Pire.Parser.Parser

       )

       where






import Control.Applicative



import Control.Monad.State.Strict

import Text.Trifecta hiding ((:@))

import qualified Data.Text as T

import Data.Bitraversable
-- import Data.Traversable


import Text.Trifecta.Delta


-- import Pire.Syntax.ConstructorNames (poorMansTraverse)
import Syntax


import Parser




import Control.Lens

import TT


-- import Data.String.Utils

-- import Data.Traversable

-- import TT


#ifdef DOCTEST
-- for the doctests
import NoPos

import Parser
import Parser_
import Wrap

-- -- import ParseUtils
import Text2String


import Syntax
import PrettyCommon (ppr)
#endif



-- addition of positions as Trifecta Deltas works, if we keep the
-- last two (byte) components of Lines at 0 (ie. always use Lines _ _ 0 0)
-- ie. given an initial position, as stored in the state,
-- the new position is calculated as a result of (initial pos + shift by parsing)
-- (in particular we don't have to split the String/T.Text by hand into lines,
-- taking different line ending conventions into account etc.)




{-- snippet Deco --}
class Deco t where
  deco :: MonadState Delta m => t -> m (t, Delta)
{-- /snippet Deco --}


{-- snippet DecoString --}
instance Deco String where
  deco s = do
    delta' <- get
    let (Lines l c _ _)= fromSuccess $ parseString ((many $ anyChar) >> position) delta' $ s
    put $ Lines l c 0 0
    return (s, delta')
{-- /snippet DecoString --}


{-- snippet DecoText --}
instance Deco T.Text where
  deco s = do
    delta' <- get
    let (Lines l c _ _) = fromSuccess $ parseString ((many $ anyChar) >> position) delta' $ T.unpack s
    put $ Lines l c 0 0
    return (s, delta')
{-- /snippet DecoText --}



-- decorate exprs (decls, etc) with exact position info
-- (relying on bitraversal, and on the fact the every token is recorded now
-- with its textual repr)
-- @decorate@ is just a shortcut for @evalState (bitraverse deco deco...)@,
-- creates a tree of pairs

-- (more fine grained than @(Pos ...)@ wrapped around only some of the exprs by the parser),
-- and works after parsing as well



-- >>> prettyPrint $ runState (bitraverse deco deco $ snd $ parse expr_ "f arg") $ beginning
-- (Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0))) (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0))),Lines 0 5 0 0)



{-|


decorate token trees with exact position info
(relying on bitraversal, and on the fact the every token is recorded now
with its textual repr),

@'decorate' e delta@ is just a shortcut for @'evalState' ('bitraverse' 'deco' 'deco' e) delta@,
creates a tree of pairs

(more fine grained than @(Pos ...)@, wrapped around only some of the exprs by the parser),
and works after parsing as well


>>> ppr $ evalState (bitraverse deco deco $ snd $ parse expr_ "f arg") $ beginning
Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0)))
     (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0)))


and works with String exprs as well



>>> ppr $ evalState (bitraverse deco deco $ t2s $ snd $ parse expr_ "f arg") $ beginning
Pair (Pair (Id ("f",Lines 0 0 0 0)) (Ws (" ",Lines 0 1 0 0)))
     (Pair (Id ("arg",Lines 0 2 0 0)) (Ws ("",Lines 0 5 0 0)))


>>> ppr $ decorate (snd $ parse expr_ "\\  x . f  a") $ beginning
Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws ("  ",Lines 0 1 0 0))
     ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))]
     ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0))
     ,Abstract [("x",Lines 0 7 0 0)]
               (Scope (Pair (Pair (Id (F (Id ("f",Lines 0 8 0 0))))
                                  (Ws ("  ",Lines 0 9 0 0)))
                            (Pair (Id (F (Id ("a",Lines 0 11 0 0))))
                                  (Ws ("",Lines 0 12 0 0)))))]


watch out however for /bound/ vars (they have no textual repr in the scope, and thus shift the result)

>>> ppr $ decorate (snd $ parse expr_ "\\  x . x  a") $ beginning
Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws ("  ",Lines 0 1 0 0))
     ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))]
     ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0))
     ,Abstract [("x",Lines 0 7 0 0)]
               (Scope (Pair (Pair (Id (B 0)) (Ws ("  ",Lines 0 8 0 0)))
                            (Pair (Id (F (Id ("a",Lines 0 10 0 0))))
                                  (Ws ("",Lines 0 11 0 0)))))]

but get exact positions, even in the case of bound vars, w\/ the help of @'Wrap.wrap'@:

>>> ppr $ decorate (wrap $ snd $ parse expr_ "\\  x . x  a") $ beginning
Node [Pair (Token ("\",Lines 0 0 0 0)) (Ws ("  ",Lines 0 1 0 0))
     ,Node [Pair (Binder ("x",Lines 0 3 0 0)) (Ws (" ",Lines 0 4 0 0))]
     ,Pair (Token (".",Lines 0 5 0 0)) (Ws (" ",Lines 0 6 0 0))
     ,Abstract_ (Scope (Pair (Pair (Bnd ("x",Lines 0 7 0 0) (Id (B 0)))
                                   (Ws ("  ",Lines 0 8 0 0)))
                             (Pair (Id (F (Id ("a",Lines 0 10 0 0))))
                                   (Ws ("",Lines 0 11 0 0)))))]

-}





-- works on exprs, decls, annots etc

{-- snippet decorate --}
decorate :: (Deco b, Deco a, Bitraversable t) =>
            t a b -> Delta -> t (a, Delta) (b, Delta)
decorate ex = evalState (bitraverse deco deco ex)
{-- /snippet decorate --}


-- can't bitraverse over modules (and thus make them Bitraversable),
-- as ConstructorNames uses Sets, which are not Traversable: traversal requires an ordering

-- workaround for modules thus: just use a triple (n-tuple)
-- could maybe use the setTraversal as outlined in src/Pire/Syntax/ConstructorNames.hs
-- (but don't need constructor names decorated with position info anyway)


-- exampl (not a doctests: result too long)
-- (silence $ runExceptT $ getModules ["samples"] "M") >>= return . decorateMsilly . nopos . last . fromRight'

-- works (and interesting maybe for the record), but of no use, since position info makes sense
-- only in syntax tree w/ white space

-- decorateMsilly (Module nm imports decls constrs) =
--   evalState ((,,,) <$> traverse deco nm
--              <*> traverse (traverse deco) imports
--              <*> traverse (bitraverse deco deco) decls
--              <*> pure constrs) beginning1



-- exampl
-- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . decorateM . wrap . nopos . last . fromRight'
-- fixed (emacs like) file pos convention, beginning1: the upper left corner is line 1, column 0


-- used initially, but unwieldy, as now we have to work with a huge tuple instead of a module





-- just pair constructors w/ a dummy Delta's
-- ie. don't care about that Delta
-- (what should it mean, anyway:
-- a constructor "Succ" eg, paired w/ a Delta, like so: ("Succ",Lines 0 0 0 0) )

-- but this makes it possible to apply the Module_ constructor in decorateM 
-- and not just the tupling (,,,,,,) as in decorateM' above


decoWithDummy :: (Deco t, MonadState Delta m) => t -> m (t, Delta)
decoWithDummy x =
  return (x, Lines 0 0 0 0)




-- --------------------------------------------------
-- a variation of the above decorateM function:
-- simpler in that everything is decorated just with dummy positions


-- -- decoWithDummy' :: Monad m => t -> m (t, Delta)
-- -- decoWithDummy' x =
-- --   return (x, Lines 0 0 0 0)


-- --   runIdentity (Module_ <$> traverse decoWithDummy' leadingWs
-- --                <*> traverse decoWithDummy' mTok
-- --                <*> traverse decoWithDummy' modnm
-- --                <*> traverse decoWithDummy' whereTok
-- --                <*> traverse (traverse decoWithDummy') mimports
-- --                <*> traverse (bitraverse decoWithDummy' decoWithDummy') dcls
-- --                <*> poorMansTraverse decoWithDummy' cs)


-- --------------------------------------------------


-- get rid of these Delta's again
-- maybe unDecorateM should go to its use site: Pretty/Modules.hs ie. ?
-- it seems strange to import Refactor.Decorate there at least

-- w/ Identity eg.
-- undecorateM $ decorateM mm


-- undecorateM (Module_ leadingWs mTok modnm whereTok mimports dcls cs) =
--   (Module_ <$> traverse fst' leadingWs
--   <*> traverse fst' mTok
--   <*> traverse fst' modnm
--   <*> traverse fst' whereTok
--   <*> traverse (traverse fst') mimports
--   <*> traverse (bitraverse fst' fst') dcls
--   <*> poorMansTraverse fst' cs)
--   where fst' = Identity . fst






-- maybe use Delta (beginning, beginning1) as a variable (point free style)
-- to take different line column number conventions into account

-- something along the lines of
-- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . (\m -> decorateM' m beginning) . nopos . last . fromRight'
-- (silence $ runExceptT $ getModules_ ["samples"] "M") >>= return . (\m -> decorateM' m beginning1) . nopos . last . fromRight'