Wrapper for evaluation, that can be reordered for efficiency

Calc.hs

{-# LANGUAGE GADTs         #-}
{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE TupleSections #-}

module Calc (
  Calc, call, runCalc, runCalcM, extractCalls,
  runCalcSortBy, runCalcSortOn, runCalcSort,
  contramapRes, mapInit, traverseInit
) where

import           Data.Function (on)
import           Data.IntMap   (IntMap)
import qualified Data.IntMap   as IM
import           Data.List     (sortBy)

-- | Calculation of @a@ with possible calls to @x -> y@ function
data Calc x y a where
  Pure :: a -> Calc x y a
  App :: Calc x y (a -> b) -> Calc x y a -> Calc x y b
  Call :: x -> Calc x y y

instance Show x => Show (Calc x y a) where
  show = \case
    Pure _     -> "Pure"
    App ca ca' -> "(App " <> show ca <> " " <> show ca' <> ")"
    Call x     -> "(Call " <> show x <> ")"

instance Functor (Calc x y) where
  fmap f = App (Pure f)
instance Applicative (Calc x y) where
  pure = Pure
  (<*>) = App

call :: x -> Calc x y y
call = Call

-- | Run calculation using given function
runCalc :: (x -> y) -> Calc x y a -> a
runCalc f = \case
  Pure a     -> a
  App cab ca -> runCalc f cab $ runCalc f ca
  Call x     -> f x

-- | Effectful version of 'runCalc'
runCalcM :: Applicative m => (x -> m y) -> Calc x y a -> m a
runCalcM f = \case
  Pure a     -> pure a
  App cab ca -> ($) <$> runCalcM f cab <*> runCalcM f ca
  Call x     -> f x

extractCalls :: Calc x y a -> (Calc Int y a, IntMap x)
extractCalls ca = let (ca', xs, _) = go 1 ca in (ca', xs)
  where
    go :: Int -> Calc x y a -> (Calc Int y a, IntMap x, Int)
    go i = \case
      Pure a     -> (Pure a, mempty, i)
      App cab ca -> (App cab' ca', xab <> xa, i'')
        where
          (cab', xab, i') = go i cab
          (ca', xa, i'') = go i' ca
      Call x     -> (Call i, IM.singleton i x, i + 1)

-- | Run reordered calculation.
runCalcSortBy :: (Monad m, Show x) =>
  (x -> x -> Ordering) -> (x -> m y) -> Calc x y a -> m a
runCalcSortBy comp f ca = do
  let (ca', imxs) = extractCalls ca
      xs = sortBy (comp `on` snd) $ IM.toList imxs
  ys <- traverse (\(k, x) -> (k, ) <$> f x) xs
  let imys = IM.fromList ys
  pure $ runCalc (imys IM.!) ca'

runCalcSortOn :: (Monad m, Ord x', Show x) =>
  (x -> x') -> (x -> m y) -> Calc x y a -> m a
runCalcSortOn g = runCalcSortBy (compare `on` g)

runCalcSort :: (Monad m, Ord x, Show x) => (x -> m y) -> Calc x y a -> m a
runCalcSort = runCalcSortBy compare

main.hs

{-# LANGUAGE ApplicativeDo    #-}
{-# LANGUAGE BlockArguments   #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}

module Main where
import           Calc                (call, runCalcSortOn)
import           Control.Monad       (when)
import           Control.Monad.State (evalState, gets, modify)
import           Data.Bifunctor      (bimap)
import           Data.List           (findIndex, isPrefixOf, permutations,
                                      tails)
import           Data.Maybe          (fromJust)
import           Data.Traversable    (for)

type Pos = (Int, Int)

class ErrPretty e where
  errPretty :: e -> [(Pos, String)]

renderErrors :: ErrPretty e => String -> [e] -> String
renderErrors src es = runCalcSortOn fst prPos h `evalState` (0, src)
  where
    h = unlines <$> for es \e ->
          unlines <$> for (errPretty e) \(pos, lbl) -> do
            loc <- call pos
            pure $ loc ++ "\n" ++ lbl
    prPos (b, e) = do
      o <- gets fst
      when (b < o) $
        error "Non monotonic error positions!"
      modify $ bimap (const b) (drop (b - o))
      gets (take (e - b + 1) . snd)

data MyError
  = Foo Pos
  | Bar Pos Pos

instance ErrPretty MyError where
  errPretty = \case
    Foo p    -> [(p, "Foo occured here!")]
    Bar p p' -> [ (p, "Bar occured here!")
                , (p', "Note: here is something related to the problem")
                ]

check :: [(String, String)]
check = map h (permutations ["42", "bar", "lorem", "foo", "ipsum", "sit"])
  where
    h strs = let str = unwords strs
                 beg s = fromJust $ subIndex s str
                 pFoo = let b = beg "foo" in (b, b + 2)
                 pBar = let b = beg "bar" in (b, b + 2)
                 p42 = let b = beg "42" in (b, b + 1)
              in (str, renderErrors str [Foo pFoo, Bar pBar p42])

main :: IO ()
main = do
  let (str, res) = head check
  putStrLn $ "Source: " <> str
  putStrLn res
  putStrLn $ "All are same: " <> show (all (\(_, r) -> r == res) check)

subIndex :: Eq a => [a] -> [a] -> Maybe Int
subIndex substr str = findIndex (isPrefixOf substr) (tails str)