{-# 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)