libhbb-0.1.1.0: Language/Haskell/HBB/Internal/TTree.hs
{-# 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)