normalized applicative.hs

normalized applicative.hs

{-# LANGUAGE Strict #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes, InstanceSigs, KindSignatures, GADTs, ConstraintKinds, ScopedTypeVariables #-}

-- http://neilsculthorpe.com/publications/constrained-monad-problem.pdf

import           Data.Function
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.Validation
import           GHC.Exts
import           Idiom.Types.SHA256

data NAF :: (* -> Constraint) -> (* -> *) -> * -> * where
  Pure :: a -> NAF c t a
  Ap :: (c x) => NAF c t (x -> a) -> t x -> NAF c t a

instance Functor (NAF c t) where
  fmap :: (a -> b) -> NAF c t a -> NAF c t b
  fmap f naf = pure f <*> naf

instance Applicative (NAF c t) where
  pure :: a -> NAF c t a
  pure = Pure
  (<*>) :: NAF c t (a -> b) -> NAF c t a -> NAF c t b
  Pure g <*> Pure a = Pure (g a)                   -- homomorphism
  n1 <*> Pure a = Pure (\g -> g a) <*> n1          -- interchange
  n1 <*> Ap n2 tx = Ap (Pure (.) <*> n1 <*> n2) tx -- composition

liftNAF :: c a => t a -> NAF c t a
liftNAF ta = Ap (Pure id) ta -- identity

foldNAF ::
     forall a c r t.
     (forall x. x -> r x)
  -> (forall y z. c y => r (y -> z) -> t y -> r z)
  -> NAF c t a
  -> r a
foldNAF pur app = foldNAF'
  where
    foldNAF' :: forall b. NAF c t b -> r b
    foldNAF' (Pure b) = pur b
    foldNAF' (Ap n tx) = app (foldNAF' n) tx

--------------------------------------------------------------------------------
-- Example

data Require a
  = PureRequire a
  | KeyRequire Int
  deriving (Show, Functor)

demoPure :: NAF Show Require Int
demoPure = liftNAF (PureRequire 3)

demoApp :: NAF Show Require Int
demoApp = (+) <$> liftNAF (PureRequire 123) <*> liftNAF (KeyRequire 1)

--------------------------------------------------------------------------------
-- Showers

showNAF :: NAF Show Require String -> String
showNAF =
  \case
    Pure x -> x
    Ap f x -> showNAF (fmap (const "") f) <> showRequire x

showRequire :: Show a => Require a -> String
showRequire =
  \case
    PureRequire a -> show a
    KeyRequire i -> "<#" ++ show i ++ ">"

--------------------------------------------------------------------------------
-- Hash

class Hashable a where hash :: a -> SHA256
instance Hashable Int where hash = sha256String . show
instance Hashable () where hash = sha256String . show

-- | Either hash the whole tree, or else return the keys that were unavailable.
hashNAF ::
     Hashable a
  => Map Int SHA256
  -> NAF Hashable Require a
  -> Validation (NonEmpty Int) SHA256
hashNAF keyHashes = go . fmap hash
  where
    go :: NAF Hashable Require SHA256 -> Validation (NonEmpty Int) SHA256
    go =
      \case
        Pure sha -> pure sha
        Ap f x -> combineShas <$> go (fmap (const (hash ())) f) <*> hashRequire x
    hashRequire :: Hashable a => Require a -> Validation (NonEmpty Int) SHA256
    hashRequire =
      \case
        PureRequire x -> pure (hash x)
        KeyRequire k ->
          case M.lookup k keyHashes of
            Nothing -> Failure (pure k)
            Just sha -> pure sha
    combineShas x y = sha256ByteString (on (<>) sha256AsHex x y)