Implementing Pcbt fuseable traversals

node/src/Unison/Runtime/Pcbt.hs

@@ -0,0 +1,85 @@
+{-# Language DeriveFunctor #-}
+{-# Language DeriveTraversable #-}
+{-# Language DeriveFoldable #-}
+{-# Language ExistentialQuantification #-}
+{-# Language GADTs #-}
+{-# Language Rank2Types #-}
+
+module Unison.Runtime.Pcbt where
+
+import Control.Monad
+import qualified Unison.Runtime.Vector as V
+
+data Labels p a = Labels { path :: p, maxPath :: p, hit :: Maybe a }
+  deriving (Functor, Foldable, Traversable)
+
+type IsBin = Bool
+
+-- | A binary tree along with a set of labels attached to each node in the tree
+data Pcbt m p a = Pcbt
+  { structure :: [Bool] -> m IsBin
+  , labels :: [Bool] -> m (Labels p a) }
+
+type Traversal m p a b r = Free (Instruction m p a b) r
+
+data Instruction m p a b r where
+  Effect :: m x -> Instruction m p a b x
+  IsLeaf :: Instruction m p a b Bool
+  Ask :: Instruction m p a b (Labels p a)
+  Skip :: Instruction m p a b ()
+  Continue :: Instruction m p a b ()
+  Emit :: b -> Instruction m p a b ()
+
+run :: Monad m
+    => Traversal m p a b r
+    -> V.Vector Bool
+    -> V.Vector b
+    -> Pcbt m p a
+    -> m (V.Vector b)
+run f cursor acc t = case f of
+  Pure _ -> pure acc
+  Bind req k -> case req of
+    Effect m -> m >>= (\x -> run (k x) cursor acc t)
+    Ask -> labels t (V.toList cursor) >>= \ls -> run (k ls) cursor acc t
+    IsLeaf -> structure t (V.toList cursor) >>= \isLeaf -> run (k isLeaf) cursor acc t
+    Emit b -> run (k ()) cursor (acc `V.snoc` b) t
+    Continue -> do
+      cursor <- advance cursor
+      maybe (pure acc) (\cursor -> run (k ()) cursor acc t) cursor
+      where
+      advance i = structure t (V.toList i) >>= \isLeaf -> case isLeaf of
+        False -> pure (Just (i `V.snoc` False))
+        True -> pure (incr i)
+    Skip -> maybe (pure acc) (\cursor -> run (k ()) cursor acc t) (incr cursor)
+
+incr :: V.Vector Bool -> Maybe (V.Vector Bool)
+incr i = case V.dropRightWhile id i of
+  i | V.isEmpty i -> Nothing
+    | otherwise   -> Just (V.init i `V.snoc` True)
+
+data Free f a
+  = Pure a
+  | forall x . Bind (f x) (x -> Free f a)
+
+instance Functor (Free f) where
+  fmap = liftM
+
+instance Applicative (Free f) where
+  pure = return
+  (<*>) = ap
+
+instance Monad (Free f) where
+  return = Pure
+  Bind x f >>= g = Bind x ((g =<<) . f)
+  Pure x >>= f = f x
+
+eval :: f a -> Free f a
+eval a = Bind a pure
+
+translate :: (forall a . f a -> g a) -> Free f a -> Free g a
+translate _ (Pure a) = Pure a
+translate u (Bind x f) = Bind (u x) (translate u . f)
+
+interpret :: Monad f => Free f a -> f a
+interpret (Bind x f) = x >>= (interpret . f)
+interpret (Pure a) = return a

node/src/Unison/Runtime/Vector.hs

@@ -1,11 +1,11 @@
 module Unison.Runtime.Vector where
 
-import Data.List hiding (length)
-import Prelude hiding (length)
+import Data.List hiding (init,length)
+import Prelude hiding (init,length)
 import qualified Data.Vector as V
 
 arity :: Int
-arity = 128
+arity = 64
 
 data Vector a =
   Vector { length :: !Int, hd :: !(V.Vector a), tl :: (Vector (V.Vector a)), buf :: !(V.Vector a) }
@@ -13,6 +13,9 @@ data Vector a =
 empty :: Vector a
 empty = Vector 0 V.empty empty V.empty
 
+isEmpty :: Vector a -> Bool
+isEmpty v = length v == 0
+
 snoc :: Vector a -> a -> Vector a
 snoc (Vector n hd tl buf) a =
   case buf `V.snoc` a of
@@ -27,6 +30,21 @@ unsafeIndex (Vector _ hd tl buf) i = case i of
   _ -> case (i - V.length hd) `divMod` arity of
          (bucket,offset) -> tl `unsafeIndex` bucket `V.unsafeIndex` offset
 
+unsafeLast :: Vector a -> a
+unsafeLast v = unsafeIndex v (length v - 1)
+
+-- | Drop the last element from this vector. Returns itself if empty.
+init :: Vector a -> Vector a
+init v@(Vector n hd tl buf) = case V.null buf of
+  False -> Vector (n-1) hd tl (V.init buf)
+  _ | n == V.length hd -> Vector (n-1) V.empty tl (V.init hd)
+  _ | n == 0 -> v
+  _ -> Vector (n-1) hd (init tl) (V.init (unsafeLast tl))
+
+dropRightWhile :: (a -> Bool) -> Vector a -> Vector a
+dropRightWhile f v | isEmpty v || not (f (unsafeLast v)) = v
+dropRightWhile f v = dropRightWhile f (init v)
+
 toList :: Vector a -> [a]
 toList v = map (unsafeIndex v) [0 .. length v - 1]
 
@@ -44,6 +62,7 @@ instance Ord a => Ord (Vector a) where
 
 instance Monoid (Vector a) where
   mempty = empty
+  mappend (Vector 0 _ _ _) v2 = v2
   mappend v1@(Vector n1 hd1 tl1 buf1) v2@(Vector n2 hd2 tl2 buf2) =
     if V.null buf1 then Vector (n1+n2) hd1 (tl1 `snoc` hd2 `mappend` tl2) buf2
     else foldl' snoc v1 (toList v2)

node/unison-node.cabal

@@ -51,6 +51,7 @@ library
     Unison.TermEdit.Extra
     Unison.Type.Extra
     Unison.Runtime.Vector
+    Unison.Runtime.Pcbt
 
   build-depends:
     aeson,