mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-25 01:08:30 +03:00
Implementing Pcbt fuseable traversals
This commit is contained in:
parent
82013b035b
commit
16db535018
85
node/src/Unison/Runtime/Pcbt.hs
Normal file
85
node/src/Unison/Runtime/Pcbt.hs
Normal file
@ -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
|
@ -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)
|
||||
|
@ -51,6 +51,7 @@ library
|
||||
Unison.TermEdit.Extra
|
||||
Unison.Type.Extra
|
||||
Unison.Runtime.Vector
|
||||
Unison.Runtime.Pcbt
|
||||
|
||||
build-depends:
|
||||
aeson,
|
||||
|
Loading…
Reference in New Issue
Block a user