Example of static analysis with Applicatives: expression with named holes.

holes.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
    FlexibleInstances, FlexibleContexts #-}
import Control.Applicative
import Control.Applicative.Lift
import Data.Functor.Compose
import Data.Functor.Constant
import Data.Maybe
import Data.Monoid

-- expr is an expression with named holes;
-- you can fill in the holes and evaluate it,
-- or get a list of the holes' names.

expr :: (Num v, Ord v, Applicative f, Holes String v f, Errs [String] f) => f v
expr = (+) <$> hole "a"
           <*> ((+) <$> check (>0) ["not an error"] (hole "b") ?: 0
                    <*> check (>0) ["c should be positive"] (hole "c"))

main :: IO ()
main = do
    print $ evaluateE expr [("a",1), ("b",2), ("c",3)]
    print $ evaluateE expr [("b",-3), ("c",-3)]
    print $ evaluateE expr [("a",1), ("b",-2), ("c",3)]
    print $ names expr

-- Innards:

class Holes k v f | f->k v where
    hole :: k -> f v
class Errs e f | f->e where
    check :: (a->Bool) -> e -> f a -> f a
    catch :: f a -> (e -> a) -> f a

(?:) :: (Errs e f) => f a -> a -> f a
fx ?: y = fx `catch` const y

evaluate :: ([(k,v)]->a) -> [(k,v)] -> a
evaluate = id
instance (Eq k) => Holes k v ((->) [(k,v)]) where
    hole k = fromJust . lookup k

evaluateE :: (Eq k)
    => (Compose ((->) [(k,v)]) (Errors [String]) a)
    -> [(k,v)] -> Either [String] a
evaluateE x kvs =
    case getCompose x kvs of
        Pure a -> Right a
        Other (Constant es) -> Left es
instance (Eq k, Monoid e, MissingKeyError k e)
         => Holes k v (Compose ((->) [(k,v)]) (Errors e)) where
    hole k = Compose $ \kvs ->
        case lookup k kvs of
            Nothing -> failure $ missingKeyError k
            Just v -> pure v
instance (Monoid e, MissingKeyError k e)
         => Errs e (Compose ((->) [(k,v)]) (Errors e)) where
    check good err x = Compose $ \kvs ->
        case getCompose x kvs of
            Other (Constant e) -> failure e
            Pure a -> if good a then pure a else failure err
    x `catch` handle = Compose $ \kvs ->
        case getCompose x kvs of
            Other (Constant e) -> pure $ handle e
            Pure a -> pure a
class MissingKeyError k e where
    missingKeyError :: k -> e
instance (Show k) => MissingKeyError k [String] where
    missingKeyError k = ["missing key " ++ show k]

names :: Phantom (v,e) (Constant [k]) a -> [k]
names = getConstant . dePhantom
-- Phantom is needed to satisfy the coverage condition.
instance Holes k v (Phantom (v,e) (Constant [k])) where
    hole k = Phantom $ Constant [k]
instance Errs e (Phantom (v,e) (Constant [k])) where
    check _ _ x = x
    x `catch` _ = x
newtype Phantom ph f a = Phantom { dePhantom :: f a }
instance (Applicative f) => Applicative (Phantom ph f) where
    pure x = Phantom $ pure x
    f <*> x = Phantom $ dePhantom f <*> dePhantom x
instance (Functor f) => Functor (Phantom ph f) where
    fmap f x = Phantom $ fmap f $ dePhantom x