exercise.hs

#!/usr/bin/env stack
-- stack --nix --resolver lts-11.7 script

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.List
import Control.Monad
import Control.Exception (assert)

type Coords a = (a, a) -- ^ (line, column)


-- Extend ordinal operations to both numbers
instance {-# OVERLAPPING #-} Ord (Coords Int) where
  a < b = (fst a) < (fst b) && (snd a) < (snd b)
  a <= b = (fst a) <= (fst b) && (snd a) <= (snd b)
  a > b = (fst a) > (fst b) && (snd a) > (snd b)
  a >= b = (fst a) >= (fst b) && (snd a) >= (snd b)

-- | A single stack trace element
data St = St
  { start :: Coords Int
  , end :: Coords Int
  } deriving (Eq, Show)


-- | We have two types of operations on the stacktrace
data OpType
  = Jumppoint -- ^ It's a jump point if it moves outside the previous scope
  | Descending -- ^ We are descending if the scope in th 'St' is narrowing
  deriving (Show, Eq)

-- | To detect the 'OpType', we need the current and next thing in the
-- stacktrace.
detect' :: St -> St -> (St, OpType)
detect' a b
  | (end a) == (end b) = (a, Descending)
  | (start a) < (start b) && (end a) >= (end b) = (a, Descending) -- If a wraps around b, we are still descending
  | otherwise = (a, Jumppoint)

detect :: [St] -> [(St, OpType)]
detect [] = error "empty list"
detect [a] = error "not enough elements"
detect [a, b] = [detect' a b]
detect (a:b:rest) = detect' a b : (detect $ b:rest)

prune :: [(St, OpType)] -> [(St, OpType)]
prune ls = filter (\(_, opType) -> opType == Jumppoint) ls

main = do
  putStrLn $ assert ([(head ex2, Jumppoint)] == detect ex2) "Jumppoint test passes"
  putStrLn $ assert ([(head ex3, Descending)] == detect ex3) "Descending test passes"
  putStrLn "Pruning:"
  print $ map show $ prune $ detect ex1


-- Examples

{- Example
1 |
2 |
3 |main = do
4 |  x <- someFunc 10
5 |  y <- someOtherfunc 53
6 |  putStrLn (show x <> show y)
8 |
9 |someFunc x = x
10|
11|someOtherfunc y = y
12|
13|
-}
ex1 :: [St]
ex1 =
    [ St { start = (3, 1),   end = (6, 29)  } -- Descending : main
    , St { start = (3, 7),   end = (6, 29)  } -- Descending : do
    , St { start = (4, 2),   end = (4, 18)  } -- Jumppoint  : x <- someFunc 10
    , St { start = (9, 0),   end = (9, 14)  } -- Jumppoint  : someFunc 10
    , St { start = (5, 2),   end = (5, 18)  } -- Jumppoint  : y <- someOtherfunc 53
    , St { start = (11, 0),  end = (11, 19) } -- Jumppoint  : someOtherfunc 53
    , St { start = (6, 2),   end = (6, 29)  } -- Descending : putStrLn
    , St { start = (6, 11),  end = (6, 29)  } -- Descending : (show x <> show y)
    , St { start = (6, 12),  end = (6, 18)  } -- Jumppoint  : show x
    , St { start = (6, 22),  end = (6, 28)  } -- Jumppoint  : show y
    ]

{- Jumppoint example
1 |(func1 arg)
2 |
3 |func1 a = undefined
-}
ex2 :: [St]
ex2 =
  [ St { start = (1, 0), end = (1, 10) }
  , St { start = (3, 0), end = (3, 20) }
  ]

{- Descending example
1|(func1
2|  (func2 arg))
3|
-}
ex3 :: [St]
ex3 =
  [ St { start = (1, 1), end = (2, 14) }
  , St { start = (2, 3), end = (2, 14) }
  ]