mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-25 17:27:52 +03:00
Using type alias for better signature readability of at/modify
This commit is contained in:
parent
12d7219553
commit
7bcc159e88
@ -4,7 +4,7 @@
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.ABT (ABT(..),abs,at,freevars,hash,into,modify,out,rename,subst,tm,Term,V) where
|
||||
module Unison.ABT (ABT(..),abs,at,At,freevars,hash,into,modify,out,rename,ReplaceAt,subst,tm,Term,V) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson (ToJSON(..),FromJSON(..))
|
||||
@ -84,8 +84,11 @@ subst t x body = case out body of
|
||||
else subst t x e
|
||||
Tm body -> tm (fmap (subst t x) body)
|
||||
|
||||
type At f a = f a -> Maybe a
|
||||
type ReplaceAt f a = f a -> Maybe (a, a -> f a)
|
||||
|
||||
-- | Extract the subterm a path points to
|
||||
at :: [f (Term f) -> Maybe (Term f)] -> Term f -> Maybe (Term f)
|
||||
at :: [At f (Term f)] -> Term f -> Maybe (Term f)
|
||||
at [] t = Just t
|
||||
at path@(hd:tl) t = case out t of
|
||||
Abs _ t -> at path t
|
||||
@ -94,10 +97,7 @@ at path@(hd:tl) t = case out t of
|
||||
|
||||
-- | Modify the subterm a path points to
|
||||
modify :: Foldable f
|
||||
=> (Term f -> Term f)
|
||||
-> [f (Term f) -> Maybe (Term f, Term f -> f (Term f))]
|
||||
-> Term f
|
||||
-> Maybe (Term f)
|
||||
=> (Term f -> Term f) -> [ReplaceAt f (Term f)] -> Term f -> Maybe (Term f)
|
||||
modify f [] t = Just (f t)
|
||||
modify f path@(hd:tl) t = case out t of
|
||||
Abs v t -> abs v <$> modify f path t
|
||||
|
@ -109,28 +109,28 @@ data PathElement
|
||||
newtype Path = Path [PathElement] deriving (Eq,Ord)
|
||||
|
||||
-- | Use a @PathElement@ to compute one step into an @F a@ subexpression
|
||||
focus :: PathElement -> F a -> Maybe (a, a -> F a)
|
||||
focus Fn (App f x) = Just (f, \f -> App f x)
|
||||
focus Arg (App f x) = Just (x, \x -> App f x)
|
||||
focus Body (Lam body) = Just (body, Lam)
|
||||
focus Body (Let bs body) = Just (body, Let bs)
|
||||
focus Body (LetRec bs body) = Just (body, LetRec bs)
|
||||
focus (Binding i) (Let bs body) =
|
||||
stepPath :: PathElement -> ABT.ReplaceAt F a
|
||||
stepPath Fn (App f x) = Just (f, \f -> App f x)
|
||||
stepPath Arg (App f x) = Just (x, \x -> App f x)
|
||||
stepPath Body (Lam body) = Just (body, Lam)
|
||||
stepPath Body (Let bs body) = Just (body, Let bs)
|
||||
stepPath Body (LetRec bs body) = Just (body, LetRec bs)
|
||||
stepPath (Binding i) (Let bs body) =
|
||||
listToMaybe (drop i bs)
|
||||
>>= \b -> Just (b, \b -> Let (take i bs ++ [b] ++ drop (i+1) bs) body)
|
||||
focus (Binding i) (LetRec bs body) =
|
||||
stepPath (Binding i) (LetRec bs body) =
|
||||
listToMaybe (drop i bs)
|
||||
>>= \b -> Just (b, \b -> LetRec (take i bs ++ [b] ++ drop (i+1) bs) body)
|
||||
focus (Index i) (Vector vs) =
|
||||
stepPath (Index i) (Vector vs) =
|
||||
vs !? i >>= \v -> Just (v, \v -> Vector (vs // [(i,v)]))
|
||||
focus _ _ = Nothing
|
||||
stepPath _ _ = Nothing
|
||||
|
||||
at :: Path -> Term -> Maybe Term
|
||||
at (Path p) t = ABT.at (map focus' p) t
|
||||
where focus' e t = fst <$> focus e t
|
||||
at (Path p) t = ABT.at (map stepPath' p) t
|
||||
where stepPath' e t = fst <$> stepPath e t
|
||||
|
||||
modify :: (Term -> Term) -> Path -> Term -> Maybe Term
|
||||
modify f (Path p) t = ABT.modify f (map focus p) t
|
||||
modify f (Path p) t = ABT.modify f (map stepPath p) t
|
||||
|
||||
-- mostly boring serialization and hashing code below ...
|
||||
|
||||
@ -159,9 +159,8 @@ instance Digest.Digestable1 F where
|
||||
Vector as -> Digest.run $ Put.putWord8 5 *> serialize (Vector.length as)
|
||||
*> traverse_ (serialize . hash) as
|
||||
Lam a -> Digest.run $ Put.putWord8 6 *> serialize (hash a)
|
||||
-- note: we use `s` to canonicalize the order of `as` before hashing the sequence
|
||||
LetRec as a -> Digest.run $ Put.putWord8 7 *> traverse_ (serialize . hash) (s as)
|
||||
*> serialize (hash a)
|
||||
-- note: we use `s` to canonicalize the order of `a:as` before hashing the sequence
|
||||
LetRec as a -> Digest.run $ Put.putWord8 7 *> traverse_ (serialize . hash) (s (a:as))
|
||||
-- here, order is significant, so leave order alone
|
||||
Let as a -> Digest.run $ Put.putWord8 8 *> traverse_ (serialize . hash) as
|
||||
*> serialize (hash a)
|
||||
|
Loading…
Reference in New Issue
Block a user