Added a MonadPut for doing hashing, so can recycle binary serialization code to do hashing as well

node/src/Unison/ABT.hs

@@ -1,5 +1,7 @@
 -- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Unison.ABT (ABT(..),abs,freevars,into,out,rename,subst,tm,Term,V) where
@@ -9,12 +11,14 @@ import Data.Aeson
 import Data.Foldable (Foldable)
 import Data.Functor.Classes
 import Data.Set (Set)
+import Data.Traversable
 import Prelude hiding (abs)
 import Unison.Symbol (Symbol)
 import qualified Data.Aeson as Aeson
 import qualified Data.Foldable as Foldable
 import qualified Data.Set as Set
 import qualified Data.Text as Text
+import qualified Unison.Digest as Digest
 import qualified Unison.JSON as J
 import qualified Unison.Symbol as Symbol
 
@@ -23,7 +27,7 @@ type V = Symbol
 data ABT f a
   = Var V
   | Abs V a
-  | Tm (f a) deriving Functor
+  | Tm (f a) deriving (Functor, Foldable, Traversable)
 
 data Term f = Term { freevars :: Set V, out :: ABT f (Term f) }
 
@@ -100,5 +104,6 @@ instance (Foldable f, J.FromJSON1 f) => FromJSON (Term f) where
 
 -- todo: binary encoder/decoder can work similarly
 
+-- a closed term with zero deps can be hashed directly
 -- hash :: IntTagged f => Term f ->
 

node/src/Unison/Digest.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+module Unison.Digest
+  ( Digest
+  , DigestM -- ctor not exported, so easy to change hash fn later
+  , run
+  ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Bytes.Put
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import qualified Crypto.Hash as H
+import qualified Data.Serialize.Put as S
+
+data PairS a = PairS a !(H.Context H.SHA3_512)
+
+type Digest = DigestM ()
+newtype DigestM a = DigestM { digest :: H.Context H.SHA3_512 -> PairS a }
+
+run :: Digest -> B.ByteString
+run d = case digest d H.hashInit of
+  PairS _ ctx -> H.digestToByteString (H.hashFinalize ctx)
+
+write :: (H.Context H.SHA3_512 -> H.Context H.SHA3_512) -> DigestM ()
+write f = DigestM (\ctx -> PairS () (f ctx))
+
+instance MonadPut DigestM where
+  putWord8 b = write (\ctx -> H.hashUpdate ctx (B.singleton b))
+  putByteString bs = write (\ctx -> H.hashUpdate ctx bs)
+  putLazyByteString bs = write (\ctx -> H.hashUpdates ctx (LB.toChunks bs))
+  flush = return () -- noop
+  -- probably inefficient, but delegate to cereal for these
+  putWord16le = putByteString . S.runPut . S.putWord16le
+  putWord16be = putByteString . S.runPut . S.putWord16be
+  putWord16host = putByteString . S.runPut . S.putWord16host
+  putWord32le = putByteString . S.runPut . S.putWord32le
+  putWord32be = putByteString . S.runPut . S.putWord32be
+  putWord32host = putByteString . S.runPut . S.putWord32host
+  putWord64le = putByteString . S.runPut . S.putWord64le
+  putWord64be = putByteString . S.runPut . S.putWord64be
+  putWord64host = putByteString . S.runPut . S.putWord64host
+  putWordhost = putByteString . S.runPut . S.putWordhost
+
+instance Monad DigestM where
+  return a = DigestM (\d -> PairS a d)
+  DigestM st >>= f = DigestM (\d -> let PairS a d' = st d in d' `seq` digest (f a) d')
+
+instance Applicative DigestM where
+  pure = return
+  (<*>) = ap
+
+instance Functor DigestM where
+  fmap = liftM

node/unison.cabal

@@ -46,6 +46,7 @@ library
 
   exposed-modules:
     Unison.ABT
+    Unison.Digest
     Unison.Distance
     Unison.Eval
     Unison.Eval.Interpreter
@@ -76,6 +77,8 @@ library
     base64-bytestring         ,
     blaze-html                >= 0.7.0.0,
     bytestring                ,
+    bytes                     >= 0.15,
+    cereal                    ,
     containers                >= 0.5,
     cryptohash                ,
     directory                 ,