mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-21 07:17:25 +03:00
More transformations
This commit is contained in:
Chris Penner
parent
6c07b36b92
commit
e013511dd8
@ -44,6 +44,7 @@ import Data.Generics.Product
|
||||
import Data.Generics.Sum
|
||||
import qualified Unison.Hash as Unison
|
||||
import qualified Unison.Hashing.V2.Convert as Convert
|
||||
import Unison.Hashing.V1.Term (unhashComponent)
|
||||
|
||||
-- lookupCtor :: ConstructorMapping -> ObjectId -> Pos -> ConstructorId -> Maybe (Pos, ConstructorId)
|
||||
-- lookupCtor (ConstructorMapping cm) oid pos cid =
|
||||
@ -112,7 +113,7 @@ data X = MkX Y
|
||||
data Y = MkY Int
|
||||
-}
|
||||
|
||||
data Entity'
|
||||
data Entity
|
||||
= TComponent Unison.Hash
|
||||
| DComponent Unison.Hash
|
||||
| Patch ObjectId
|
||||
@ -210,10 +211,30 @@ migratePatch = error "not implemented"
|
||||
migrateNamespace :: HashId -> ByteString -> m _
|
||||
migrateNamespace = error "not implemented"
|
||||
|
||||
migrateTermComponent :: HashId -> ByteString -> m _
|
||||
migrateTermComponent = error "not implemented"
|
||||
migrateTermComponent :: forall m v a. Codebase m v a -> Unison.Hash -> m (Sync.TrySyncResult Entity)
|
||||
migrateTermComponent Codebase{..} hash = fmap (either id id) . runExceptT $ do
|
||||
-- getTermComponentWithTypes :: Hash -> m (Maybe [(Term v a, Type v a)]),
|
||||
component <- getTermComponentWithTypes hash >>= \case
|
||||
Nothing -> error $ "Hash was missing from codebase: " <> show hash
|
||||
Just component -> pure component
|
||||
|
||||
migrateDeclComponent :: forall m v a. Codebase m v a -> Unison.Hash -> m (Sync.TrySyncResult Entity')
|
||||
let componentIDMap :: Map Reference.Id (Term v a, Type v a)
|
||||
componentIDMap = Map.fromList $ Reference.componentFor hash component
|
||||
let unhashed :: Map Reference.Id (v, Term v a)
|
||||
unhashed = unhashComponent (fst <$> componentIDMap)
|
||||
let allContainedReferences :: [Reference.Id]
|
||||
allContainedReferences = foldMap (ABT.find findReferenceIds) (snd <$> Map.elems)
|
||||
when (not . null $ allContainedReferences) $ throwE $ Sync.Missing allContainedReferences
|
||||
|
||||
-- unhashComponent :: forall v a. Var v
|
||||
-- => Map Reference.Id (Term v a)
|
||||
-- -> Map Reference.Id (v, Term v a)
|
||||
|
||||
undefined
|
||||
|
||||
|
||||
|
||||
migrateDeclComponent :: forall m v a. Codebase m v a -> Unison.Hash -> m (Sync.TrySyncResult Entity)
|
||||
migrateDeclComponent Codebase{..} hash = fmap (either id id) . runExceptT $ do
|
||||
declComponent :: [DD.Decl v a] <- lift (getDeclComponent hash) >>= \case
|
||||
Nothing -> error "handle this" -- not non-fatal!
|
||||
@ -275,34 +296,34 @@ migrateDeclComponent Codebase{..} hash = fmap (either id id) . runExceptT $ do
|
||||
-- Map v (Memory.DD.DataDeclaration v a) ->
|
||||
-- ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)]
|
||||
|
||||
let newComponent :: ([(v, Reference.Id, DD.DataDeclaration v a)])
|
||||
let newComponent :: [(v, Reference.Id, DD.DataDeclaration v a)]
|
||||
newComponent = Convert.hashDecls (Map.fromList $ Map.elems remappedReferences)
|
||||
for newComponent $ \(v, newReferenceId, dd) -> do
|
||||
field @"declLookup" %= Map.insert (vToReference Map.! v) newReferenceId
|
||||
for_ newComponent $ \(v, newReferenceId, dd) -> do
|
||||
field @"declLookup" %= Map.insert (vToOldReference Map.! v) newReferenceId
|
||||
putTypeDeclaration newReference (_ d)
|
||||
pure Sync.Done
|
||||
|
||||
|
||||
structural type Ping x = P1 (Pong x)
|
||||
P1 : forall x. Pong x -> Ping x
|
||||
-- structural type Ping x = P1 (Pong x)
|
||||
-- P1 : forall x. Pong x -> Ping x
|
||||
|
||||
structural type Pong x = P2 (Ping x) | P3 Nat
|
||||
P2 : forall x. Ping x -> Pong x
|
||||
P3 : forall x. Nat -> Pong x
|
||||
-- structural type Pong x = P2 (Ping x) | P3 Nat
|
||||
-- P2 : forall x. Ping x -> Pong x
|
||||
-- P3 : forall x. Nat -> Pong x
|
||||
|
||||
|
||||
|
||||
|
||||
end up with
|
||||
decl Ping (Ref.Id #abc pos=0)
|
||||
decl Pong (Ref.Id #abc pos=1)
|
||||
ctor P1: #abc pos=0 cid=0
|
||||
ctor P2: #abc pos=1 cid=0
|
||||
ctor P3: #abc pos=1 cid=1
|
||||
|
||||
we unhashComponent and get:
|
||||
{ X -> structural type X x = AAA (Y x)
|
||||
, Y -> structural type Y x = BBB (X x) | CCC Nat }
|
||||
-- end up with
|
||||
-- decl Ping (Ref.Id #abc pos=0)
|
||||
-- decl Pong (Ref.Id #abc pos=1)
|
||||
-- ctor P1: #abc pos=0 cid=0
|
||||
-- ctor P2: #abc pos=1 cid=0
|
||||
-- ctor P3: #abc pos=1 cid=1
|
||||
--
|
||||
-- we unhashComponent and get:
|
||||
-- { X -> structural type X x = AAA (Y x)
|
||||
-- , Y -> structural type Y x = BBB (X x) | CCC Nat }
|
||||
|
||||
|
||||
|
||||
@ -339,13 +360,55 @@ remapReferences declMap = \case
|
||||
-- recordRefsInType :: MonadState MigrationState m => Type v a -> WriterT [Reference.Id] m (Type v a)
|
||||
-- recordRefsInType = _
|
||||
|
||||
findReferenceIds :: Type v a -> ABT.FindAction Reference.Id
|
||||
findReferenceIds = ABT.out >>> \case
|
||||
findTypeReferenceIds :: Type v a -> ABT.FindAction Reference.Id
|
||||
findTypeReferenceIds = ABT.out >>> \case
|
||||
ABT.Tm (Type.Ref (Reference.DerivedId r)) -> ABT.Found r
|
||||
x -> ABT.Continue
|
||||
|
||||
findTermReferenceIds :: Term f v a -> [Reference.Id]
|
||||
findTermReferenceIds t = flip ABT.find (ABT.out t) \case
|
||||
ABT.Tm f -> ABT.Found (findReferencesInTermF f)
|
||||
x -> ABT.Continue
|
||||
|
||||
findReferencesInTermF :: Unison.Term.F typeVar typeAnn patternAnn a -> [Reference.Id]
|
||||
findReferencesInTermF = ABT.find \case
|
||||
Ref (Reference.DerivedId refId) -> ABT.Found [refId]
|
||||
Constructor (Reference.DerivedId refId) _conID -> ABT.Found [refId]
|
||||
Request (Reference.DerivedId refId) _conID -> ABT.Found [refId]
|
||||
Ann _ typ -> ABT.Found (ABT.find findTypeReferenceIds typ)
|
||||
TermLink referent -> case referent of
|
||||
Ref' (Reference.DerivedId refId) -> ABT.Found [refId]
|
||||
-- Double check that ConType isn't part of the hash, remove it if it is.
|
||||
Con' (Reference.DerivedId refId) _conID _conType -> ABT.Found [refId]
|
||||
TypeLink (Reference.DerivedId refId) -> ABT.Found [refId]
|
||||
Match _ matchCases -> foldMap (\MatchCase pat _ -> findReferencesInPattern pat) matchCases
|
||||
_ -> ABT.Continue
|
||||
|
||||
findReferencesInPattern :: Traversal' () -> Pattern loc -> [Reference.Id]
|
||||
findReferencesInPattern
|
||||
= \case
|
||||
Unbound{} -> []
|
||||
Var{} -> []
|
||||
Boolean{} -> []
|
||||
Int{} -> []
|
||||
Nat{} -> []
|
||||
Float{} -> []
|
||||
Text{} -> []
|
||||
Char{} -> []
|
||||
Constructor _loc ref _constructorId ps ->
|
||||
let rs = case ref of
|
||||
DerivedId refId -> [refId]
|
||||
Builtin{} -> []
|
||||
in rs <> foldMap findReferencesInPattern ps
|
||||
As _loc p -> findReferencesInPattern p
|
||||
EffectPure _loc p -> findReferencesInPattern p
|
||||
EffectBind _loc ref _constructorId ps p
|
||||
-> let rs = case ref of
|
||||
DerivedId refId -> [refId]
|
||||
Builtin{} -> []
|
||||
in rs <> foldMap findReferencesInPattern (p:ps)
|
||||
SequenceLiteral _loc ps -> foldMap findReferencesInPattern ps
|
||||
SequenceOp _loc p _seqOp p' -> foldMap findReferencesInPattern [p, p']
|
||||
|
||||
-- data DataDeclaration v a = DataDeclaration {
|
||||
-- modifier :: Modifier,
|
||||
|
||||
@ -1,17 +1,20 @@
|
||||
-- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Unison.ABT where
|
||||
|
||||
import Unison.Prelude
|
||||
import Prelude hiding (abs, cycle)
|
||||
|
||||
import Control.Lens (Lens', use, (.=))
|
||||
import Control.Lens (Lens', use, (.=), Fold, folding, LensLike', Setter')
|
||||
import Control.Monad.State (MonadState, evalState)
|
||||
import qualified Data.Foldable as Foldable
|
||||
import Data.Functor.Identity (runIdentity)
|
||||
@ -25,12 +28,17 @@ data ABT f v r
|
||||
= Var v
|
||||
| Cycle r
|
||||
| Abs v r
|
||||
| Tm (f r) deriving (Functor, Foldable, Traversable)
|
||||
| Tm (f r)
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
-- deriving Data
|
||||
|
||||
|
||||
-- | At each level in the tree, we store the set of free variables and
|
||||
-- a value of type `a`. Variables are of type `v`.
|
||||
data Term f v a = Term { freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a) }
|
||||
|
||||
-- deriving instance (Data a, Data v, Typeable f, Data (f (Term f v a)), Ord v) => Data (Term f v a)
|
||||
|
||||
-- | A class for variables.
|
||||
--
|
||||
-- * `Set.notMember (freshIn vs v) vs`:
|
||||
@ -454,6 +462,9 @@ foreachSubterm f e = case out e of
|
||||
subterms :: (Ord v, Traversable f) => Term f v a -> [Term f v a]
|
||||
subterms t = runIdentity $ foreachSubterm pure t
|
||||
|
||||
subterms_ :: (Ord v, Traversable f) => Fold (Term f v a) (Term f v a)
|
||||
subterms_ = folding subterms
|
||||
|
||||
-- | `visit f t` applies an effectful function to each subtree of
|
||||
-- `t` and sequences the results. When `f` returns `Nothing`, `visit`
|
||||
-- descends into the children of the current subtree. When `f` returns
|
||||
@ -471,8 +482,22 @@ visit f t = flip fromMaybe (f t) $ case out t of
|
||||
Abs x e -> abs' (annotation t) x <$> visit f e
|
||||
Tm body -> tm' (annotation t) <$> traverse (visit f) body
|
||||
|
||||
subTermsSetter_ :: (Traversable f, Ord v) => Setter' (Term f v a) (Term f v a)
|
||||
subTermsSetter_ f tm = visit (Just . f) tm
|
||||
|
||||
visitT :: (Traversable f, Monad m, Ord v)
|
||||
=> (Term f v a) -> m (Term f v a)
|
||||
-> Term f v a
|
||||
-> m (Term f v a)
|
||||
visitT f tm = f tm >>= \(Term )
|
||||
Var _ -> pure t
|
||||
Cycle body -> cycle' (annotation t) <$> visit' f body
|
||||
Abs x e -> abs' (annotation t) x <$> visit' f e
|
||||
Tm body -> f body >>= (fmap (tm' (annotation t)) . traverse (visit' f))
|
||||
|
||||
|
||||
-- | Apply an effectful function to an ABT tree top down, sequencing the results.
|
||||
visit' :: (Traversable f, Applicative g, Monad g, Ord v)
|
||||
visit' :: (Traversable f, Monad g, Ord v)
|
||||
=> (f (Term f v a) -> g (f (Term f v a)))
|
||||
-> Term f v a
|
||||
-> g (Term f v a)
|
||||
@ -491,11 +516,21 @@ rewriteDown :: (Traversable f, Ord v)
|
||||
=> (Term f v a -> Term f v a)
|
||||
-> Term f v a
|
||||
-> Term f v a
|
||||
rewriteDown f t = let t' = f t in case out t' of
|
||||
Var _ -> t'
|
||||
Cycle body -> cycle' (annotation t) (rewriteDown f body)
|
||||
Abs x e -> abs' (annotation t) x (rewriteDown f e)
|
||||
Tm body -> tm' (annotation t) (rewriteDown f `fmap` body)
|
||||
rewriteDown f tm = runIdentity $ rewriteDown (Identity . f) tm
|
||||
|
||||
|
||||
-- | Setter' (Term f v a) (Term f v a)
|
||||
rewriteDown_ :: (Traversable f, Monad m, Ord v)
|
||||
=> (Term f v a -> m (Term f v a))
|
||||
-> Term f v a
|
||||
-> m (Term f v a)
|
||||
rewriteDown_ f t = do
|
||||
t' <- f t
|
||||
case out t' of
|
||||
Var _ -> t'
|
||||
Cycle body -> cycle' (annotation t') <$> rewriteDown' f body
|
||||
Abs x e -> abs' (annotation t') x <$> rewriteDown' f e
|
||||
Tm body -> tm' (annotation t') <$> (rewriteDown' f `fmap` body)
|
||||
|
||||
data Subst f v a =
|
||||
Subst { freshen :: forall m v' . Monad m => (v -> m v') -> m v'
|
||||
|
||||
Loading…
Reference in New Issue
Block a user