Separate the namespaces for search
This commit is contained in:
Kirill Andreev
parent
ba3c0a76d9
commit
c26bc044ee
@ -54,7 +54,7 @@ function insert (const h : heap ; const e : heap_elt) : heap is
|
||||
parent := i/2n;
|
||||
largest := i;
|
||||
if parent >= 1n then {
|
||||
if heap_elt_lt (get_force (parent,h), get_force(i,h))) then {
|
||||
if heap_elt_lt (get_force (parent,h), get_force(i,h)) then {
|
||||
largest := parent;
|
||||
const tmp : heap_elt = get_force (i,h);
|
||||
h[i] := get_force(parent, h);
|
||||
|
||||
10
src/test/contracts/namespaces.ligo
Normal file
10
src/test/contracts/namespaces.ligo
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
type cards is record
|
||||
cards : cards
|
||||
end
|
||||
|
||||
const cards : cards = record [cards = cards]
|
||||
|
||||
const cards : cards = cards with record [cards = cards]
|
||||
|
||||
const cards : cards = cards.cards
|
||||
@ -75,7 +75,7 @@ module.exports = grammar({
|
||||
type_decl: $ =>
|
||||
seq(
|
||||
"type",
|
||||
field("typeName", $.Name),
|
||||
field("typeName", $.TypeName),
|
||||
"is",
|
||||
field("typeValue", $._type_expr),
|
||||
),
|
||||
@ -109,14 +109,14 @@ module.exports = grammar({
|
||||
|
||||
_core_type: $ =>
|
||||
choice(
|
||||
$.Name,
|
||||
$.TypeName,
|
||||
$.invokeBinary,
|
||||
$.invokeUnary,
|
||||
),
|
||||
|
||||
invokeBinary: $ =>
|
||||
seq(
|
||||
field("typeConstr", choice('map', 'big_map', $.Name)),
|
||||
field("typeConstr", choice('map', 'big_map', $.TypeName)),
|
||||
field("arguments", $.type_tuple),
|
||||
),
|
||||
|
||||
@ -159,7 +159,7 @@ module.exports = grammar({
|
||||
|
||||
field_decl: $ =>
|
||||
seq(
|
||||
field("fieldName", $.Name),
|
||||
field("fieldName", $.FieldName),
|
||||
':',
|
||||
field("fieldType", $._type_expr),
|
||||
),
|
||||
@ -575,6 +575,8 @@ module.exports = grammar({
|
||||
|
||||
path: $ => choice($.Name, $._projection),
|
||||
|
||||
fpath: $ => choice($.FieldName, $._projection),
|
||||
|
||||
module_field: $ =>
|
||||
seq(
|
||||
field("module", $.Name_Capital),
|
||||
@ -616,7 +618,7 @@ module.exports = grammar({
|
||||
sepBy1('.', field("index", $.selection)),
|
||||
),
|
||||
|
||||
selection: $ => choice($.Name, $.Int),
|
||||
selection: $ => choice($.FieldName, $.Int),
|
||||
|
||||
record_expr: $ =>
|
||||
choice(
|
||||
@ -642,14 +644,14 @@ module.exports = grammar({
|
||||
|
||||
field_assignment: $ =>
|
||||
seq(
|
||||
field("name", $.Name),
|
||||
field("name", $.FieldName),
|
||||
'=',
|
||||
field("_rhs", $._expr),
|
||||
),
|
||||
|
||||
field_path_assignment: $ =>
|
||||
seq(
|
||||
field("lhs", $.path),
|
||||
field("lhs", $.fpath),
|
||||
'=',
|
||||
field("_rhs", $._expr),
|
||||
),
|
||||
@ -747,6 +749,8 @@ module.exports = grammar({
|
||||
Nat: $ => /([1-9][0-9_]*|0)n/,
|
||||
Tez: $ => /([1-9][0-9_]*|0)(\.[0-9_]+)?(tz|tez|mutez)/,
|
||||
Bytes: $ => /0x[0-9a-fA-F]+/,
|
||||
FieldName: $ => /[a-z][a-zA-Z0-9_]*/,
|
||||
TypeName: $ => /[a-z][a-zA-Z0-9_]*/,
|
||||
Name: $ => /[a-z][a-zA-Z0-9_]*/,
|
||||
Name_Capital: $ => /[A-Z][a-zA-Z0-9_]*/,
|
||||
Keyword: $ => /[A-Za-z][a-z]*/,
|
||||
|
||||
@ -198,7 +198,7 @@ rangeToLoc (Range (a, b, _) (c, d, _) _) =
|
||||
loadFromVFS
|
||||
:: Core.LspFuncs ()
|
||||
-> J.Uri
|
||||
-> IO (Pascal (Product [[ScopedDecl], Range, [Text]]))
|
||||
-> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]]))
|
||||
loadFromVFS funs uri = do
|
||||
Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
|
||||
let txt = virtualFileText vf
|
||||
@ -206,7 +206,9 @@ loadFromVFS funs uri = do
|
||||
(tree, _) <- runParser contract (Text fin txt)
|
||||
return $ addLocalScopes tree
|
||||
|
||||
loadByURI :: J.Uri -> IO (Pascal (Product [[ScopedDecl], Range, [Text]]))
|
||||
loadByURI
|
||||
:: J.Uri
|
||||
-> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]]))
|
||||
loadByURI uri = do
|
||||
case J.uriToFilePath uri of
|
||||
Just fin -> do
|
||||
|
||||
@ -12,56 +12,67 @@ import Tree
|
||||
import Range
|
||||
import Lattice
|
||||
import Pretty
|
||||
import Product
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
findScopedDecl
|
||||
:: ( HasLocalScope info
|
||||
, HasRange info
|
||||
:: ( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
)
|
||||
=> Range
|
||||
-> Pascal info
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe ScopedDecl
|
||||
findScopedDecl pos tree = do
|
||||
point <- lookupTree pos tree
|
||||
lookupEnv (ppToText $ void point) (getLocalScope (infoOf point))
|
||||
let info = infoOf point
|
||||
let fullEnv = getElem info
|
||||
do
|
||||
cat <- getElem info
|
||||
let filtered = filter (ofCategory cat) fullEnv
|
||||
lookupEnv (ppToText $ void point) filtered
|
||||
|
||||
definitionOf
|
||||
:: ( HasLocalScope info
|
||||
, HasRange info
|
||||
:: ( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
)
|
||||
=> Range
|
||||
-> Pascal info
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe Range
|
||||
definitionOf pos tree =
|
||||
_sdOrigin <$> findScopedDecl pos tree
|
||||
|
||||
typeOf
|
||||
:: ( HasLocalScope info
|
||||
, HasRange info
|
||||
:: ( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
)
|
||||
=> Range
|
||||
-> Pascal info
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe (Either (Pascal ()) Kind)
|
||||
typeOf pos tree =
|
||||
_sdType =<< findScopedDecl pos tree
|
||||
|
||||
implementationOf
|
||||
:: ( HasLocalScope info
|
||||
, HasRange info
|
||||
:: ( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
)
|
||||
=> Range
|
||||
-> Pascal info
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe Range
|
||||
implementationOf pos tree =
|
||||
_sdBody =<< findScopedDecl pos tree
|
||||
|
||||
referencesOf
|
||||
:: ( HasLocalScope info
|
||||
, HasRange info
|
||||
:: ( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
)
|
||||
=> Range
|
||||
-> Pascal info
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe [Range]
|
||||
referencesOf pos tree =
|
||||
_sdRefs <$> findScopedDecl pos tree
|
||||
|
||||
@ -39,6 +39,12 @@ contract =
|
||||
name :: Parser (Pascal ASTInfo)
|
||||
name = ranged do pure Name <*> token "Name"
|
||||
|
||||
typeName :: Parser (Pascal ASTInfo)
|
||||
typeName = ranged do pure TypeName <*> token "TypeName"
|
||||
|
||||
fieldName :: Parser (Pascal ASTInfo)
|
||||
fieldName = ranged do pure FieldName <*> token "FieldName"
|
||||
|
||||
capitalName :: Parser (Pascal ASTInfo)
|
||||
capitalName = ranged do pure Name <*> token "Name_Capital"
|
||||
|
||||
@ -65,7 +71,7 @@ typedecl = do
|
||||
subtree "type_decl" do
|
||||
ranged do
|
||||
pure TypeDecl
|
||||
<*> inside "typeName:" name
|
||||
<*> inside "typeName:" typeName
|
||||
<*> inside "typeValue:" newtype_
|
||||
|
||||
vardecl :: Parser (Pascal ASTInfo)
|
||||
@ -185,7 +191,7 @@ field_path_assignment = do
|
||||
subtree "field_path_assignment" do
|
||||
ranged do
|
||||
pure FieldAssignment
|
||||
<*> inside "lhs:path" do qname <|> projection
|
||||
<*> inside "lhs:fpath" do fqname <|> projection
|
||||
<*> inside "_rhs" expr
|
||||
|
||||
map_patch :: Parser (Pascal ASTInfo)
|
||||
@ -556,6 +562,13 @@ qname = do
|
||||
<*> name
|
||||
<*> pure []
|
||||
|
||||
fqname :: Parser (Pascal ASTInfo)
|
||||
fqname = do
|
||||
ranged do
|
||||
pure QualifiedName
|
||||
<*> fieldName
|
||||
<*> pure []
|
||||
|
||||
qname' :: Parser (Pascal ASTInfo)
|
||||
qname' = do
|
||||
ranged do
|
||||
@ -640,7 +653,7 @@ projection = do
|
||||
selection :: Parser (Pascal ASTInfo)
|
||||
selection = do
|
||||
inside "index:selection"
|
||||
$ ranged do pure At <*> name
|
||||
$ ranged do pure At <*> fieldName
|
||||
<|> ranged do pure Ix <*> token "Int"
|
||||
<|>
|
||||
inside "index" do
|
||||
@ -677,7 +690,7 @@ record_expr = do
|
||||
inside "assignment:field_assignment" do
|
||||
ranged do
|
||||
pure Assignment
|
||||
<*> inside "name" name
|
||||
<*> inside "name" fieldName
|
||||
<*> inside "_rhs" expr
|
||||
|
||||
fun_call :: Parser (Pascal ASTInfo)
|
||||
@ -789,7 +802,7 @@ field_decl = do
|
||||
subtree "field_decl" do
|
||||
ranged do
|
||||
pure TField
|
||||
<*> inside "fieldName" name
|
||||
<*> inside "fieldName" fieldName
|
||||
<*> inside "fieldType" newtype_
|
||||
|
||||
type_ :: Parser (Pascal ASTInfo)
|
||||
@ -819,7 +832,7 @@ type_ =
|
||||
|
||||
core_type = do
|
||||
select
|
||||
[ ranged do pure TVar <*> name
|
||||
[ ranged do pure TVar <*> typeName
|
||||
, subtree "invokeBinary" do
|
||||
ranged do
|
||||
pure TApply
|
||||
@ -849,7 +862,7 @@ typeTuple = do
|
||||
-- example = "../../../src/test/contracts/amount.ligo"
|
||||
-- example = "../../../src/test/contracts/annotation.ligo"
|
||||
-- example = "../../../src/test/contracts/arithmetic.ligo"
|
||||
example = "../../../src/test/contracts/assign.ligo"
|
||||
-- example = "../../../src/test/contracts/assign.ligo"
|
||||
-- example = "../../../src/test/contracts/attributes.ligo"
|
||||
-- example = "../../../src/test/contracts/bad_timestamp.ligo"
|
||||
-- example = "../../../src/test/contracts/bad_type_operator.ligo"
|
||||
@ -866,7 +879,7 @@ example = "../../../src/test/contracts/assign.ligo"
|
||||
-- example = "../../../src/test/contracts/loop.ligo"
|
||||
-- example = "../../../src/test/contracts/redeclaration.ligo"
|
||||
-- example = "../../../src/test/contracts/includer.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
example = "../../../src/test/contracts/namespaces.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
|
||||
@ -48,32 +48,81 @@ type CollectM = State (Product [FullEnv, [Range]])
|
||||
|
||||
type AddRefsM = State FullEnv
|
||||
|
||||
type FullEnv = Map Range [ScopedDecl]
|
||||
data FullEnv = FullEnv
|
||||
{ vars :: Env
|
||||
, types :: Env
|
||||
}
|
||||
|
||||
data Category = Variable | Type
|
||||
|
||||
emptyEnv = FullEnv Map.empty Map.empty
|
||||
|
||||
with Variable (FullEnv vs ts) f = FullEnv (f vs) ts
|
||||
with Type (FullEnv vs ts) f = FullEnv vs (f ts)
|
||||
|
||||
grab Variable (FullEnv vs ts) = vs
|
||||
grab Type (FullEnv vs ts) = ts
|
||||
|
||||
type Env = Map Range [ScopedDecl]
|
||||
|
||||
ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
|
||||
ofCategory Variable _ = True
|
||||
ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
|
||||
ofCategory _ _ = False
|
||||
|
||||
-- | Calculate scopes and attach to all tree points declarations that are
|
||||
-- visible there.
|
||||
--
|
||||
addLocalScopes
|
||||
:: HasRange (Product xs)
|
||||
:: Contains Range xs
|
||||
=> Pascal (Product xs)
|
||||
-> Pascal (Product ([ScopedDecl] : xs))
|
||||
-> Pascal (Product ([ScopedDecl] : Maybe Category : xs))
|
||||
addLocalScopes tree =
|
||||
fmap (\xs -> Cons (envAt envWithREfs $ getRange xs) xs) tree
|
||||
fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1
|
||||
where
|
||||
tree1 = addNameCategories tree
|
||||
envWithREfs = getEnvTree tree
|
||||
|
||||
addNameCategories
|
||||
:: Contains Range xs
|
||||
=> Pascal (Product xs)
|
||||
-> Pascal (Product (Maybe Category : xs))
|
||||
addNameCategories tree = flip evalState emptyEnv do
|
||||
traverseMany
|
||||
[ Visit \r (Name t) -> do
|
||||
modify $ getRange r `addRef` (Variable, t)
|
||||
return $ (Cons (Just Variable) r, Name t)
|
||||
|
||||
, Visit \r (TypeName t) -> do
|
||||
modify $ getRange r `addRef` (Type, t)
|
||||
return $ (Cons (Just Type) r, TypeName t)
|
||||
]
|
||||
(Cons Nothing)
|
||||
tree
|
||||
|
||||
getEnvTree tree = envWithREfs
|
||||
where
|
||||
envWithREfs = flip execState env do
|
||||
flip traverseOnly tree \r (Name t) -> do
|
||||
modify $ getRange r `addRef` t
|
||||
return $ Name t
|
||||
traverseMany
|
||||
[ Visit \r (Name t) -> do
|
||||
modify $ getRange r `addRef` (Variable, t)
|
||||
return $ (r, Name t)
|
||||
|
||||
, Visit \r (TypeName t) -> do
|
||||
modify $ getRange r `addRef` (Type, t)
|
||||
return $ (r, TypeName t)
|
||||
]
|
||||
id
|
||||
tree
|
||||
|
||||
env
|
||||
= execCollectM
|
||||
$ traverseTree pure tree
|
||||
|
||||
envAt :: FullEnv -> Range -> [ScopedDecl]
|
||||
fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
|
||||
fullEnvAt fe r = envAt (grab Type fe) r <> envAt (grab Variable fe) r
|
||||
|
||||
envAt :: Env -> Range -> [ScopedDecl]
|
||||
envAt env pos =
|
||||
Map.elems scopes
|
||||
where
|
||||
@ -83,21 +132,25 @@ envAt env pos =
|
||||
isCovering = (pos <?)
|
||||
toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
|
||||
|
||||
addRef :: Range -> Text -> FullEnv -> FullEnv
|
||||
addRef r n env = Map.union (go range) env
|
||||
addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
|
||||
addRef r (cat, n) env =
|
||||
with cat env \slice ->
|
||||
Map.union
|
||||
(go slice $ range slice)
|
||||
slice
|
||||
where
|
||||
go (r' : rest) =
|
||||
let decls = env Map.! r'
|
||||
go slice (r' : rest) =
|
||||
let decls = slice Map.! r'
|
||||
in
|
||||
case updateOnly n r addRefToDecl decls of
|
||||
(True, decls) -> Map.singleton r' decls
|
||||
(False, decls) -> Map.insert r' decls (go rest)
|
||||
go [] = Map.empty
|
||||
(False, decls) -> Map.insert r' decls (go slice rest)
|
||||
go _ [] = Map.empty
|
||||
|
||||
range
|
||||
range slice
|
||||
= List.sortBy partOrder
|
||||
$ filter (r <?)
|
||||
$ Map.keys env
|
||||
$ Map.keys slice
|
||||
|
||||
addRefToDecl sd = sd
|
||||
{ _sdRefs = r : _sdRefs sd
|
||||
@ -125,25 +178,28 @@ enter :: Range -> CollectM ()
|
||||
enter r = do
|
||||
modify $ modElem (r :)
|
||||
|
||||
define :: ScopedDecl -> CollectM ()
|
||||
define sd = do
|
||||
define :: Category -> ScopedDecl -> CollectM ()
|
||||
define cat sd = do
|
||||
r <- gets (head . getElem)
|
||||
modify
|
||||
$ modElem @FullEnv
|
||||
$ Map.insertWith (++) r [sd]
|
||||
$ modElem @FullEnv \env ->
|
||||
with cat env
|
||||
$ Map.insertWith (++) r [sd]
|
||||
|
||||
leave :: CollectM ()
|
||||
leave = modify $ modElem @[Range] tail
|
||||
|
||||
-- | Run the computation with scope starting from empty scope.
|
||||
execCollectM :: CollectM a -> FullEnv
|
||||
execCollectM action = getElem $ execState action $ Cons Map.empty (Cons [] Nil)
|
||||
execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil)
|
||||
|
||||
instance {-# OVERLAPS #-} Pretty FullEnv where
|
||||
pp = block . map aux . Map.toList
|
||||
pp = block . map aux . Map.toList . mergeFE
|
||||
where
|
||||
aux (r, decls) =
|
||||
pp r `indent` block decls
|
||||
aux (r, fe) =
|
||||
pp r `indent` block fe
|
||||
|
||||
mergeFE (FullEnv a b) = a <> b
|
||||
|
||||
-- | The type/value declaration.
|
||||
data ScopedDecl = ScopedDecl
|
||||
@ -172,7 +228,7 @@ lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
|
||||
-- | Add a type declaration to the current scope.
|
||||
defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
|
||||
defType name kind body = do
|
||||
define
|
||||
define Type
|
||||
$ ScopedDecl
|
||||
(void name)
|
||||
(getRange $ infoOf name)
|
||||
@ -194,7 +250,7 @@ def
|
||||
-> Maybe (Pascal a)
|
||||
-> CollectM ()
|
||||
def name ty body = do
|
||||
define
|
||||
define Variable
|
||||
$ ScopedDecl
|
||||
(void name)
|
||||
(getRange $ infoOf name)
|
||||
@ -276,4 +332,6 @@ instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where
|
||||
|
||||
instance UpdateOver CollectM QualifiedName (Pascal a)
|
||||
instance UpdateOver CollectM Path (Pascal a)
|
||||
instance UpdateOver CollectM Name (Pascal a) where
|
||||
instance UpdateOver CollectM Name (Pascal a)
|
||||
instance UpdateOver CollectM TypeName (Pascal a)
|
||||
instance UpdateOver CollectM FieldName (Pascal a)
|
||||
|
||||
@ -20,7 +20,7 @@ import Tree
|
||||
type Pascal = Tree
|
||||
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
|
||||
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
|
||||
, Declaration, Contract
|
||||
, Declaration, Contract, TypeName, FieldName
|
||||
]
|
||||
|
||||
data Contract it
|
||||
@ -170,12 +170,20 @@ data Path it
|
||||
deriving (Show) via PP (Path it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Name it = Name
|
||||
newtype Name it = Name
|
||||
{ _raw :: Text
|
||||
}
|
||||
deriving (Show) via PP (Name it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
newtype TypeName it = TypeName Text
|
||||
deriving (Show) via PP (TypeName it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
newtype FieldName it = FieldName Text
|
||||
deriving (Show) via PP (TypeName it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
instance Pretty1 Contract where
|
||||
pp1 = \case
|
||||
Contract decls ->
|
||||
@ -307,7 +315,15 @@ instance Pretty1 Pattern where
|
||||
|
||||
instance Pretty1 Name where
|
||||
pp1 = \case
|
||||
Name raw -> pp raw
|
||||
Name raw -> pp raw
|
||||
|
||||
instance Pretty1 TypeName where
|
||||
pp1 = \case
|
||||
TypeName raw -> pp raw
|
||||
|
||||
instance Pretty1 FieldName where
|
||||
pp1 = \case
|
||||
FieldName raw -> pp raw
|
||||
|
||||
instance Pretty1 Path where
|
||||
pp1 = \case
|
||||
|
||||
@ -181,11 +181,11 @@ traverseOnly act = go
|
||||
|
||||
go tree = pure tree
|
||||
|
||||
data Visit fs a m where
|
||||
data Visit fs a b m where
|
||||
Visit
|
||||
:: (Element f fs, Traversable f)
|
||||
=> (a -> f (Tree fs a) -> m (f (Tree fs a)))
|
||||
-> Visit fs a m
|
||||
=> (a -> f (Tree fs a) -> m (b, f (Tree fs a)))
|
||||
-> Visit fs a b m
|
||||
|
||||
traverseMany
|
||||
:: ( Apply Functor fs
|
||||
@ -193,26 +193,27 @@ traverseMany
|
||||
, Apply Traversable fs
|
||||
, Monad m
|
||||
)
|
||||
=> [Visit fs a m]
|
||||
=> [Visit fs a b m]
|
||||
-> (a -> b)
|
||||
-> Tree fs a
|
||||
-> m (Tree fs a)
|
||||
traverseMany visitors = go
|
||||
-> m (Tree fs b)
|
||||
traverseMany visitors orElse = go
|
||||
where
|
||||
go tree = aux visitors
|
||||
where
|
||||
aux (Visit visitor : rest) = do
|
||||
case match tree of
|
||||
Just (r, fa) -> do
|
||||
fa' <- visitor r fa
|
||||
(r', fa') <- visitor r fa
|
||||
fa'' <- traverse go fa'
|
||||
return $ mk r fa''
|
||||
return $ mk r' fa''
|
||||
Nothing -> do
|
||||
aux rest
|
||||
aux [] = do
|
||||
case tree of
|
||||
Tree (Right (r, union)) -> do
|
||||
union' <- traverse go union
|
||||
return $ Tree (Right (r, union'))
|
||||
return $ Tree (Right (orElse r, union'))
|
||||
|
||||
-- | Make a tree out of a layer and an info.
|
||||
mk :: (Functor f, Element f fs) => info -> f (Tree fs info) -> Tree fs info
|
||||
|
||||
Loading…
Reference in New Issue
Block a user