Haskell segment tree with lazy propagation

gistfile1.hs

import           Control.Applicative
import           Control.Monad
import qualified Data.ByteString.Char8 as BS
import           Data.List
import qualified Data.Map              as M
import           Data.Maybe
import qualified Data.Vector           as V

data SegTree a =
    Node {
      val                   :: a
    , lazy                  :: a
    , left, right           :: Int
    , leftChild, rightChild :: SegTree a
    } |
    Leaf {
      val         :: a
    , lazy        :: a
    , left, right :: Int
    } deriving (Show, Eq, Ord)


initTree :: (Num a, Eq a) => [a] -> SegTree a
initTree xs = aux 0 (n - 1)
    where
      vs = V.fromList xs
      n = V.length vs
      aux l r
            | l == r = Leaf { val = vs V.! l, lazy = 0, left = l, right = r}
            | otherwise =
                let mid = (l + r) `div` 2
                    lChild = aux l mid
                    rChild = aux (mid + 1) r
                in Node { val = val lChild + val rChild
                        , left = l, right = r, lazy = 0
                        , leftChild = lChild, rightChild = rChild
                        }

updateNode :: (Num a, Eq a) => SegTree a -> SegTree a
updateNode rt =
    if (lazy rt) == 0 then
        rt
    else
        let lc = leftChild rt
            rc = rightChild rt
            nlc = lc {lazy = (lazy lc) + (lazy rt)}
            nrc = rc {lazy = (lazy rc) + (lazy rt)}
            r = right rt
            l = left rt
        in rt { val = (val rt) + (lazy rt) * (fromIntegral $ r - l +1)
              , leftChild = nlc, rightChild = nrc
              }


queryTree :: (Num a, Eq a) => SegTree a -> Int -> Int -> (a, SegTree a)
queryTree root l r
    | l > r || r < left root || l > right root = (0, root)
    | otherwise =
        let nr = updateNode root
        in if (left nr) >= l && (right nr) <= r then
               (val nr, nr)
           else
               ((fst $ queryTree (leftChild nr) l r) +
                (fst $ queryTree (rightChild nr) l r), nr)


updateTree :: (Num a, Eq a) => SegTree a -> Int -> Int -> a -> SegTree a
updateTree root l r inc
    | l > r = root
    | otherwise = aux nr
    where
      nr = updateNode root
      aux root
          | (right root) < l || (left root) > r = root
          | (left root) >= l && (right root) <= r =
              let lc = leftChild root
                  rc = rightChild root
                  [a, b] = [left root, right root]
              in
                if a /= b then
                    root { val = (val root) + inc * (fromIntegral $ b - a + 1)
                         , leftChild = lc { lazy = (lazy lc) + inc}
                         , rightChild = rc { lazy = (lazy rc) + inc }
                         }
                else
                    root { val = (val root) + inc * (fromIntegral $ b - a + 1)}
          | otherwise =
              let nlc = updateTree (leftChild root) l r inc
                  nrc = updateTree (rightChild root) l r inc
              in root { val = (val nlc) + (val nrc)
                      , leftChild = nlc, rightChild = nrc
                      }


readInt' = fst . fromJust . BS.readInt
readInteger' = fst . fromJust. BS.readInteger


-- solve :: Int -> [[Integer]] -> [Integer]
solve n qs = foldl' (\ (root, acc) q ->
                         if (head q) == 0 then
                             (updateTree root (q !! 1 - 1) (q !! 2 - 1) (q !! 3), acc)
                         else
                             let (ans, nr) = queryTree root (q !! 1 - 1) (q !! 2 - 1)
                             in (nr, ans : acc) )
             (initTree $ take n (repeat 0), [])
             qs


main :: IO ()
main = do
  tc <- readLn :: IO Int
  forM_ [1..tc] $ \i -> do
      [n, q] <- map readInt' . BS.words <$> BS.getLine
      contents <- replicateM q BS.getLine
      let queries = map (\ x -> map readInt' (BS.words x)) contents
          (_, ans) = solve n queries
      putStrLn $ show ans
--      putStrLn $ intercalate " " $ map show (solve n queries)

      --      putStrLn $ intercalate " " $ map show (solve n input)
  putStrLn "hello world"