module Language.Haskell.HBB.TestModes.ApplyTTree (
ApplyTTreeArgs(..),
defaultApplyTTreeArgs,
testModeApplyTTree
) where
import Language.Haskell.HBB.Internal.TTreeColor
import Language.Haskell.HBB.Internal.TTreeJSON
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.TTree
import qualified Data.ByteString.Char8 as StrictByteString
import System.Environment (getArgs)
import Data.Generics
import FastString (unpackFS,mkFastString)
import Data.List (sortBy,union)
import SrcLoc
data ApplyTTreeArgs = ApplyTTreeArgs { applyToShowContext :: Bool
, applyToShowAnsiColored :: Bool }
defaultApplyTTreeArgs :: ApplyTTreeArgs
defaultApplyTTreeArgs = ApplyTTreeArgs { applyToShowContext = False , applyToShowAnsiColored = False }
testModeApplyTTree :: ApplyTTreeArgs -> IO String
testModeApplyTTree options = do
jsonString <- StrictByteString.getContents
case decodeTTreeFromJSON jsonString of
Left msg -> fail $ "Failure reading TTree from stdin: " ++ msg
Right tree -> applyTTree' options tree
applyTTree' :: ApplyTTreeArgs -> (RealSrcSpan,ClientTTree) -> IO String
applyTTree'
(ApplyTTreeArgs { applyToShowContext = sc , applyToShowAnsiColored = sa })
(spn,tree) = do
let occFile = unpackFS $ srcSpanFile spn
occFileContent <- readFile occFile
let affectedNames = [occFile] `union` collectFilenames (toBufSpan spn,tree)
fileCache <- cacheFiles affectedNames
let alteredContent = case sc of
True ->
let lns = lines occFileContent
in case sa of
True -> applyColoredTTree fileCache (toBufSpan spn,tree) lns
False -> applyTTree fileCache (toBufSpan spn,tree) lns
False -> case sa of
True -> applyColoredTTree fileCache (pointBufSpan 1 1,tree) [""]
False -> applyTTree fileCache (pointBufSpan 1 1,tree) [""]
return $ unlines alteredContent