{-# OPTIONS -XDeriveDataTypeable #-}
module Language.Haskell.HBB.Internal.TTree where

import Language.Haskell.HBB.Internal.SrcSpan
import Data.Generics
import FastString (unpackFS)
import Data.List (union,sort)
import Data.List (sortBy)
import SrcLoc
-- SrcLoc is a module from GHC which can be used to describe locations and
-- spans of the source code. It is used at this point to avoid the introduction
-- of (some) user-defined types to describe the transformation tree.

data TTreeNode a b = Addition a
                   | Display  b deriving (Show,Eq)

-- | This is the generic data structure representing a transformation tree.
--
-- /T/ransformation/Tree/
--
-- The transformation tree is a recursive data structure to represent
-- modifications to text (files). It is used to represent the changes to source
-- code made by the inlining function feature.
-- 
-- /Cover-Range/
--
-- The cover-range is the snippet of code that should be hidden by the new
-- text. For the root of the tree this is a RealSrcSpan (which has a filename
-- attached). For other location the cover-range refers to the text inserted by
-- the parent element.
-- 
-- /Children/
--
-- The text that has been added by for example an addition may be altered again
-- by the usage of nested transformations. These transformations always refer
-- to their parent transformation whichs means that the Cover-Range for example
-- contains lines- and column-indices which refer only to the snipped added by
-- their parent transformation (and not the whole text which is referred to by
-- the top-most addition or display). INVARIANT: Moreover the source-spans
-- elements of child-transformations must be disjoint. Reassembling the
-- transformation-tree can so be done by sorting the child-tranformations by
-- their cover-range in reverse order (so that the last position is taken
-- first) and applying them.
--
-- Instance of TTree produced by ConvertibleToTTree:
--
-- > TTree LineBuf RealSrcSpan InsertionInfo
--
-- Instance of TTree that is searialized to JSON:
--
-- > TTree LineBuf (RealSrcSpan,Int) BufSpan
data TTree a b c = TTree (TTreeNode a b) [(c,TTree a b c)] deriving (Show,Eq)

-- The ClientTTree is the data structure that is (as the name says) reported to
-- the client (in contrast to InternalTTree which is used by HBB internally).
-- It can be (de-)serialized to and from JSON with the functions from the
-- module Language.Haskell.HBB.Internal.TTreeJSON.
type ClientTTree = TTree LineBuf (RealSrcSpan,Int) BufSpan

-- This function takes a file cache, a transformation tree and a line buffer
-- and returns a modified verion of the line buffer to which all
-- transformations contained by the tree have been applied.
applyTTree :: [(FilePath,LineBuf)] -> (BufSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> LineBuf -> LineBuf
applyTTree fc tree lns = applyTTreeGeneric Nothing fc id tree lns

-- The following is the core function that applies a TTree to produce a certain
-- output text. This function has been made as generic as needed to use it
-- within the module LibTTreeColor for the function 'applyColoredTTree' as
-- well. By passing a non-Nothing value as first parameter the behaviour of
-- this function may be influenced.
applyTTreeGeneric :: Maybe (a,attr -> a,(a,attr) -> (LineBuf,LineBuf,LineBuf) -> (LineBuf,LineBuf,LineBuf)) 
    -> [(FilePath,LineBuf)] -- The file cache. An exception is thrown when it
                            -- does not contain all files that occure in the tree.
                            -- This obviously only needed for the displays.
    -> (attr -> BufSpan)    -- The function to extract the BufSpan
    -> (attr,TTree LineBuf (RealSrcSpan,Int) attr) -- The tree itself. 'attr' will mostly be BufSpan.
    -> LineBuf              -- The line buffer the transformation should be applied to
    -> LineBuf
applyTTreeGeneric info fc getSpan (attr,tree) lns = 
    let (initLines,subjLines,traiLines) = splitBufferedLinesAtBufSpan lns (getSpan attr)

        compareNonOverlSpns' (attr1,_) (attr2,_) =
            let (BufSpan l1 _) = getSpan attr1
                (BufSpan l2 _) = getSpan attr2
            in  compare l1 l2

        -- This is special code currently only needed by the ANSI-coloring
        -- feature.

        newInfo = case info of
            Nothing                 -> Nothing
            Just (_,infoFun,finFun) -> Just (infoFun attr,infoFun,finFun)

        -- When this tree is an addition the string to add is given directly,
        -- when it is a display we have to extract it from the file cache.

        (focusStr,childs) = case tree of
            (TTree (Addition ad           ) ch) -> (ad,ch)
            (TTree (Display (spn,offsHint)) ch) -> 
                let buf       = getCacheElement (unpackFS $ srcSpanFile spn) fc
                    (_,res,_) = splitBufferedLinesAtBufSpan buf (toBufSpan spn)
                    res'      = case res of 
                                []     -> []
                                (x:xs) -> if offsHint < 0
                                          then x:(map (\line -> drop (-offsHint) line           ) xs)
                                          else x:(map (\line -> (replicate offsHint ' ') ++ line) xs)
                in  (res',ch)

        -- Applying the childs one after another (may) move the indices within
        -- the original text. This must be considered by the implementation.
        -- Adding two times the string 'fac' will possible move the second
        -- addition by 3 letters...
        --
        -- To solve this problem we apply the children in reversed order which
        -- means that the children with the RealSrcSpan that is located the
        -- nearest from the back (last line) is applied first. This works as by
        -- the definition of TTree the RealSrcSpans of the childrens mustn't
        -- overlap (this is an invariant of the tree).
        --
        -- Note that foldr applies in reversed order!
        childsRes :: LineBuf
        childsRes = foldr 
                        (applyTTreeGeneric newInfo fc getSpan) 
                        focusStr 
                        (sortBy compareNonOverlSpns' childs)

        (p1,p2,p3) = case info of
            Nothing                 -> (initLines,childsRes,traiLines)
            Just (i,_,finalizerFun) -> finalizerFun (i,attr) (initLines,childsRes,traiLines)
    in  reassembleSplit (p1,p2,p3)

getCacheElement :: FilePath -> [(FilePath,LineBuf)] -> LineBuf
getCacheElement f1 c = case filter (\(f2,_) -> f2 == f1) c of
    [(_,x)] -> x
    []      -> error $ "internal error (File cache is incomplete. Missing element: " ++ f1 ++ ")"
    _       -> error   "internal error (duplicates in the file cache)"
        
-- Collecting Filenames
-- ====================
--
-- This function collects the filenames within a TTree. File names may have two
-- origins. 
-- -> The first one is the cover-range of the root-element (which points to the
-- file where the transformation is applied (all children refer to locations
-- relative to the next upper element in the tree)). 
-- -> The second ones are the source-display elements of a Display.
--
-- The file names of the TTree are collected to read the individual files in
-- advance and cache their content for faster access.
--
-- Principally the tree should only contain two files it refers to as inlining
-- a function will have a source file and a (maybe identical) target file.
--
collectFilenames :: (a,TTree b (RealSrcSpan,Int) a) -> [FilePath]
collectFilenames tree = collectFilenames' tree []
    where
        collectFilenames' :: (a,TTree b (RealSrcSpan,Int) a) -> [String] -> [String]
        collectFilenames' (_,(TTree (Display (spn,_)) ch)) acc = 
            foldr collectFilenames' (union [(unpackFS (srcSpanFile spn))] acc) ch
        collectFilenames' (_,(TTree _                 ch)) acc = 
            -- An addition doesn't ship a filename...
            foldr collectFilenames' acc ch

-- Caching Files
-- =============
--
-- This functions creates a cache from the list of filenames passed as first
-- argument. A file cache like the one created here is for example needed by
-- the functions that apply a TTree (like 'applyTTree' or 'applyColoredTTree').
cacheFiles :: [FilePath] -> IO [(FilePath,LineBuf)]
cacheFiles fs = cacheFilesAcc fs []
    where
        cacheFilesAcc :: [FilePath] -> [(FilePath,LineBuf)] -> IO [(FilePath,LineBuf)]
        cacheFilesAcc []     acc = return acc
        cacheFilesAcc (f:fs) acc = do
            content <- readFile f
            cacheFilesAcc fs ((f,str2LineBuf content):acc)