Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.