A draft provenance arrow.

Provenance.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE Arrows #-}
module Bonsai.Provenance
where

import Control.Category
import Control.Arrow
import Prelude hiding ((.), id)

data ProvenanceT p a b where
  Fiat :: (a -> b) -> ProvenanceT p a b
  Composition :: ProvenanceT p b c -> ProvenanceT p a b -> ProvenanceT p a c
  Parallel :: ProvenanceT p a b -> ProvenanceT p a' b' -> ProvenanceT p (a, a') (b, b')
  Choice :: ProvenanceT p a b -> ProvenanceT p a' b' -> ProvenanceT p (Either a a') (Either b b')
  Atomic :: p () a -> a -> ProvenanceT p () a
  Function :: p a b -> (a -> b) -> ProvenanceT p a b

instance (forall a b.Show (p a b)) => Show (ProvenanceT p a b) where
  show (Fiat _) = "Fiat"
  show (Composition x y) = "Composition(" ++ show x ++ ", " ++ show y ++ ")"
  show (Parallel x y) = "Parallel(" ++ show x ++ ", " ++ show y ++ ")"
  show (Choice x y) = "Choice(" ++ show x ++ ", " ++ show y ++ ")"
  show (Atomic p x) = "Atomic(" ++ show p ++ ")"
  show (Function p f) = "Function(" ++ show p ++ ")"

instance Category (ProvenanceT p) where
  id = Fiat id
  (.) = Composition

instance Arrow (ProvenanceT p) where
  arr = Fiat
  (***) = Parallel

instance ArrowChoice (ProvenanceT p) where
  (+++) = Choice

evaluate :: ProvenanceT p a b -> a -> b
evaluate (Fiat f) = f
evaluate (Composition g f) = evaluate g . evaluate f
evaluate (Parallel f g) = \(x, y) -> (evaluate f x, evaluate g y)
evaluate (Choice f g) = \case
  Left x -> Left $ evaluate f x
  Right x -> Right $ evaluate g x
evaluate (Atomic _ a) = const a
evaluate (Function _ f) = f

evaluateP :: ProvenanceT p a b -> a -> WithProvenance p a b
evaluateP (Fiat f) = \x -> (FiatP, f x)
evaluateP (Composition g f) = \x -> let (p, y) = evaluateP f x
                                        (p', y') = evaluateP g y
                                     in (p' . p, y')
evaluateP (Parallel f g) = \(x, y) -> let (p, x') = evaluateP f x
                                          (p', y') = evaluateP g y
                                       in (ParallelP p p', (x', y'))
evaluateP (Choice f g) = \case
  Left x -> let (p, x') = evaluateP f x
             in (ChoiceLeftP p, Left x')
  Right x -> let (p, x') = evaluateP g x
              in (ChoiceRightP p, Right x')
evaluateP (Atomic p a) = const (AtomicP p, a)
evaluateP (Function p f) = \x -> (AtomicP p, f x)

type WithProvenance p a b = (Provenance p a b, b)

data Provenance p :: (* -> * -> *) where
  FiatP :: Provenance p a b
  AtomicP :: p a b -> Provenance p a b
  CompositionP :: Provenance p b c -> Provenance p a b -> Provenance p a c
  ParallelP :: Provenance p a b -> Provenance p a' b' -> Provenance p (a, a') (b, b')
  ChoiceLeftP :: Provenance p a b -> Provenance p (Either a a') (Either b b')
  ChoiceRightP :: Provenance p a' b' -> Provenance p (Either a a') (Either b b')

instance Category (Provenance p) where
  id = FiatP
  (.) = CompositionP

deriving instance (forall a b.Show (p a b)) => Show (Provenance p a b)

showP :: (forall a' b'.Show (p a' b')) => Provenance p a b -> [String]
showP FiatP = []
showP (AtomicP p) = [show p]
showP (CompositionP p2 p1) = showP p1 ++ showP p2
showP (ParallelP p1 p2) = showP p1 ++ showP p2
showP (ChoiceLeftP p) = showP p
showP (ChoiceRightP p) = showP p

testP :: (forall a' b'.Show (p a' b')) => ProvenanceT p a b -> a -> ([String], b)
testP f x = let (p, x') = evaluateP f x
             in (showP p, x')

newtype StringProvenance a b = StringProvenance String

instance Show (StringProvenance a b) where
  show (StringProvenance x) = x

input :: (Show a) => String -> a -> ProvenanceT StringProvenance () a
input name x = Atomic (StringProvenance $ "The input named " ++ name ++ " is " ++ show x ++ ".") x

c2f :: ProvenanceT StringProvenance Rational Rational
c2f = proc x -> do
  y <- Function (StringProvenance "First we multiply by 9/5.") (* (9/5)) -< x
  z <- Function (StringProvenance "Then we add 32.") (+32) -< y
  returnA -< z