diff --git a/cli/src/Graph/MaterializePath.hs b/cli/src/Graph/MaterializePath.hs index 1df9e07..f3cc6ad 100644 --- a/cli/src/Graph/MaterializePath.hs +++ b/cli/src/Graph/MaterializePath.hs @@ -96,7 +96,7 @@ materializeNPath firstNid normalizedPath = do traverseRooted nid RootedDeterministicPath {..} = do rootBranches' :: [ [ ( DeterministicPath NID, - OSet (DPBranch FullyAnchored) + NonNull (OSet (DPBranch FullyAnchored)) ) ] ] <- @@ -106,15 +106,16 @@ materializeNPath firstNid normalizedPath = do <&> map (\(rs, bs) -> (,bs) <$> rs) <&> choices rootBranches'' :: - [(OMap (DeterministicPath NID) (OSet (DPBranch NID)), NID)] <- + [(OMap (DeterministicPath NID) (NonNull (OSet (DPBranch NID))), NID)] <- rootBranches' & (traverse . traverse) - (\(dp, bs) -> (dp,) <$> traverseBranches dp.target.anchor bs) + (\(dp, bs) -> (dp,) <$> traverseBranches dp.target.anchor (toNullable bs)) <&> map (map \(r, bas) -> (\(b, a) -> ((r, b), a)) <$> bas) <&> concatMap choices <&> mapMaybe (ensureSameAnchors . impureNonNull) <&> ordNub - <&> over (mapped . _1) (mapFromList . toNullable) + <&> over (mapped . _1) (impureNonNull . mapFromList . toNullable) + <&> over (mapped . _1 . mapped . _2) impureNonNull rootBranches'' & (traverse . _2) (\x -> traversePointlike False x target) <&> concatMap (\(rbs, ts) -> (rbs,) <$> ts) @@ -178,11 +179,11 @@ materializeNPath firstNid normalizedPath = do DPOutgoing transition -> traverseTransition nid (.outgoing) DPOutgoing transition DPIncoming transition -> traverseTransition nid (.incoming) DPIncoming transition DPSequence bs1 midpoint bs2 -> do - bs1's <- traverseBranches nid bs1 + bs1's <- traverseBranches nid (toNullable bs1) uptoMidpoints :: [(OSet (DPBranch NID), PointlikeDeterministicPath NID)] <- bs1's & (traverse . _2) (\x -> traversePointlike False x midpoint) <&> concatMap (\(bs1', ms) -> (bs1',) <$> ms) uptoMidpoints - & (traverse . _2) (\p -> (p,) <$> traverseBranches p.anchor bs2) - <&> concatMap (\(bs1', (p, bs2'ts)) -> first (DPSequence bs1' p) <$> bs2'ts) + & (traverse . _2) (\p -> (p,) <$> traverseBranches p.anchor (toNullable bs2)) + <&> concatMap (\(bs1', (p, bs2'ts)) -> first (\bs2' -> DPSequence (impureNonNull bs1') p (impureNonNull bs2')) <$> bs2'ts) diff --git a/cli/src/Models/NormalizedPath.hs b/cli/src/Models/NormalizedPath.hs index 7a9fb7f..decc9b7 100644 --- a/cli/src/Models/NormalizedPath.hs +++ b/cli/src/Models/NormalizedPath.hs @@ -24,8 +24,7 @@ data FullyAnchored data DeterministicPath a = Rooted (RootedDeterministicPath a) | Pointlike (PointlikeDeterministicPath a) - deriving stock (Eq, Ord, Show, Generic, Lift) - deriving anyclass (NFData) + deriving stock (Eq, Ord, Show, Generic) instance HasField "target" (DeterministicPath a) (PointlikeDeterministicPath a) where getField (Rooted p) = p.target @@ -39,11 +38,15 @@ instance HasField "target" (DeterministicPath a) (PointlikeDeterministicPath a) -- at least two distinct roots (otherwise it should be Pointlike and the -- branches should go in a DPSequence in the branch set) data RootedDeterministicPath a = RootedDeterministicPath - { rootBranches :: OMap (DeterministicPath a) (OSet (DPBranch a)), + { rootBranches :: + NonNull + (OMap + (DeterministicPath a) + (NonNull (OSet (DPBranch a))) + ), target :: PointlikeDeterministicPath a } - deriving stock (Eq, Ord, Show, Generic, Lift) - deriving anyclass (NFData) + deriving stock (Eq, Ord, Show, Generic) -- | A pointlike deterministic path. This is a path that has a single Root -- and the target is the same as the Root. @@ -54,8 +57,7 @@ data PointlikeDeterministicPath a -- | each of these can also be inverted, see `invertLoop` for details loops :: OSet (DPBranch a) } - deriving stock (Eq, Ord, Show, Generic, Lift) - deriving anyclass (NFData) + deriving stock (Eq, Ord, Show, Generic) unanchored :: PointlikeDeterministicPath Anchor unanchored = PointlikeDeterministicPath Unanchored mempty @@ -91,15 +93,13 @@ data DPBranch a -- instead of -- @Sequence (Sequence (singleton a) m (singleton b)) n (singleton c)@) DPSequence - (OSet (DPBranch a)) + (NonNull (OSet (DPBranch a))) (PointlikeDeterministicPath a) - (OSet (DPBranch a)) - deriving stock (Eq, Ord, Show, Generic, Lift) - deriving anyclass (NFData) + (NonNull (OSet (DPBranch a))) + deriving stock (Eq, Ord, Show, Generic) newtype NormalizedPath a = NormalizedPath {union :: Set (DeterministicPath a)} - deriving stock (Eq, Ord, Show, Generic, Lift) - deriving anyclass (NFData) + deriving stock (Eq, Ord, Show, Generic) pointify :: RootedDeterministicPath Anchor -> @@ -108,7 +108,7 @@ pointify (branchify -> (roots, branches, target)) = do protoPoint <- foldlM1 mergePointlike (target `ncons` toList roots) Just protoPoint - { loops = protoPoint.loops <> branches, + { loops = protoPoint.loops <> toNullable branches, anchor = fromJustEx $ mergeAnchor (JoinPoint mempty) protoPoint.anchor } @@ -120,43 +120,43 @@ pointify (branchify -> (roots, branches, target)) = do -- sequencing two Rooted paths. branchify :: RootedDeterministicPath Anchor -> - ( OSet (PointlikeDeterministicPath Anchor), - OSet (DPBranch Anchor), + ( NonNull (OSet (PointlikeDeterministicPath Anchor)), + NonNull (OSet (DPBranch Anchor)), PointlikeDeterministicPath Anchor ) branchify RootedDeterministicPath {..} = - let (rooteds, pointlikes) = partitionRootedPointlike (mapToList rootBranches) + let (rooteds, pointlikes) = partitionRootedPointlike (mapToList (toNullable rootBranches)) (rootedRoots, rootedBranches) = rooteds & over (mapped . _1) branchify & map convertToBranches & unzip - & bimap unions unions + & bimap unions (unions . map toNullable) (pointlikeRoots, pointlikeBranches) = pointlikes & unzip - & bimap setFromList unions - in ( pointlikeRoots <> rootedRoots, - pointlikeBranches <> rootedBranches, + & bimap setFromList (unions . map toNullable) + in ( impureNonNull $ pointlikeRoots <> rootedRoots, + impureNonNull $ pointlikeBranches <> rootedBranches, target ) where convertToBranches :: - ( ( OSet (PointlikeDeterministicPath Anchor), - OSet (DPBranch Anchor), + ( ( NonNull (OSet (PointlikeDeterministicPath Anchor)), + NonNull (OSet (DPBranch Anchor)), PointlikeDeterministicPath Anchor ), - OSet (DPBranch Anchor) + NonNull (OSet (DPBranch Anchor)) ) -> ( OSet (PointlikeDeterministicPath Anchor), - OSet (DPBranch Anchor) + NonNull (OSet (DPBranch Anchor)) ) convertToBranches ((w, x, y), z) = - (w, singletonSet $ smartBuildSequence x y z) + (toNullable w, singletonNNSet $ smartBuildSequence x y z) partitionRootedPointlike :: - [(DeterministicPath a, OSet (DPBranch a))] -> - ( [(RootedDeterministicPath a, OSet (DPBranch a))], - [(PointlikeDeterministicPath a, OSet (DPBranch a))] + [(DeterministicPath a, NonNull (OSet (DPBranch a)))] -> + ( [(RootedDeterministicPath a, NonNull (OSet (DPBranch a)))], + [(PointlikeDeterministicPath a, NonNull (OSet (DPBranch a)))] ) partitionRootedPointlike = partitionEithers . map \case @@ -169,7 +169,7 @@ intersectDeterministicPaths :: Maybe (DeterministicPath Anchor) intersectDeterministicPaths (Rooted p1) (Rooted p2) = do newTarget <- mergePointlike p1.target p2.target - let newSourceBranches = unionWith (<>) p1.rootBranches p2.rootBranches + let newSourceBranches = impureNonNull $ unionWith (<>) (toNullable p1.rootBranches) (toNullable p2.rootBranches) Just . Rooted $ smartBuildRootedDeterministicPath newSourceBranches newTarget intersectDeterministicPaths (Pointlike p1) (Pointlike p2) = do Pointlike <$> mergePointlike p1 p2 @@ -212,45 +212,42 @@ mergePointlike p1 p2 = do smartBuildSequence :: (HasCallStack, Ord a) => - OSet (DPBranch a) -> + NonNull (OSet (DPBranch a)) -> PointlikeDeterministicPath a -> - OSet (DPBranch a) -> + NonNull (OSet (DPBranch a)) -> DPBranch a -smartBuildSequence as1 midpoint bs2 - | null as1 || null bs2 = - error "invariant broken: both branch sets must be nonempty" - | otherwise = case toList as1 of - [DPSequence leftBs leftMid leftRightBs] -> - DPSequence leftBs leftMid . singletonSet $ - smartBuildSequence leftRightBs midpoint bs2 - _ -> DPSequence as1 midpoint bs2 +smartBuildSequence as1 midpoint bs2 = case toList as1 of + [DPSequence leftBs leftMid leftRightBs] -> + DPSequence leftBs leftMid $ + singletonNNSet $ + smartBuildSequence leftRightBs midpoint bs2 + _ -> DPSequence as1 midpoint bs2 smartBuildRootedDeterministicPath :: (HasCallStack, Ord a) => - OMap (DeterministicPath a) (OSet (DPBranch a)) -> + NonNull (OMap (DeterministicPath a) (NonNull (OSet (DPBranch a)))) -> PointlikeDeterministicPath a -> RootedDeterministicPath a -smartBuildRootedDeterministicPath rootBranches target - | null rootBranches = - error "invariant broken: rootBranches must be nonempty" - | otherwise = case mapToList rootBranches of - [(r@(Rooted (RootedDeterministicPath (length -> 1) _)), b)] -> - smartBuildRootedDeterministicPath - (uncurry singletonMap (smartBuildRootBranch r b)) - target - _ -> RootedDeterministicPath rootBranches target +smartBuildRootedDeterministicPath rootBranches target = + case mapToList (toNullable rootBranches) of + [(r@(Rooted (RootedDeterministicPath (olength -> 1) _)), b)] -> + let (dp, branches) = smartBuildRootBranch r b + in smartBuildRootedDeterministicPath + (singletonNNMap dp branches) + target + _ -> RootedDeterministicPath rootBranches target smartBuildRootBranch :: (HasCallStack, Ord a) => DeterministicPath a -> - OSet (DPBranch a) -> + NonNull (OSet (DPBranch a)) -> ( DeterministicPath a, - OSet (DPBranch a) + NonNull (OSet (DPBranch a)) ) smartBuildRootBranch - (Rooted (RootedDeterministicPath (mapToList -> [(dp, branches)]) midpoint)) + (Rooted (RootedDeterministicPath (mapToList . toNullable -> [(dp, branches)]) midpoint)) branchExtensions = - (dp, singletonSet $ smartBuildSequence branches midpoint branchExtensions) + (dp, singletonNNSet $ smartBuildSequence branches midpoint branchExtensions) smartBuildRootBranch dp branches = (dp, branches) sequenceDeterministicPaths :: @@ -266,7 +263,7 @@ sequenceDeterministicPaths Just $ Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Pointlike newRoot) branches) + (singletonNNMap (Pointlike newRoot) branches) target sequenceDeterministicPaths (Rooted p1) (Pointlike p2) = do newTarget <- mergePointlike p1.target p2 @@ -277,7 +274,7 @@ sequenceDeterministicPaths midpoint <- foldlM1 mergePointlike (p1.target `ncons` toList roots) Just . Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Rooted p1 {target = midpoint}) p2Branches) + (singletonNNMap (Rooted p1 {target = midpoint}) p2Branches) p2Target invertBranch :: (Ord a) => DPBranch a -> DPBranch a @@ -286,9 +283,9 @@ invertBranch = \case DPIncoming trans -> DPOutgoing trans DPSequence as1 midpoint bs2 -> DPSequence - (mapOSet invertBranch as1) + (mapOSetNN invertBranch as1) (invertPointlike midpoint) - (mapOSet invertBranch bs2) + (mapOSetNN invertBranch bs2) flipBranch :: (Ord a) => DPBranch a -> DPBranch a flipBranch = \case @@ -296,11 +293,10 @@ flipBranch = \case DPIncoming trans -> DPIncoming trans DPSequence as1 m12 bs23 -> case flipBranch <$> toList bs23 of - [] -> error "invariant broken: both branch sets must be nonempty" [DPSequence bs2 m23 bs3] -> smartBuildSequence bs3 (invertPointlike m23) $ - singletonSet (smartBuildSequence bs2 (invertPointlike m12) as1) - xs -> smartBuildSequence (setFromList xs) (invertPointlike m12) as1 + singletonNNSet (smartBuildSequence bs2 (invertPointlike m12) as1) + xs -> smartBuildSequence (impureNonNull $ setFromList xs) (invertPointlike m12) as1 backwardsCount :: DPBranch a -> Int backwardsCount = \case @@ -345,10 +341,10 @@ invertDeterministicPath (Pointlike p) = Just . Pointlike $ invertPointlike p invertDeterministicPath (Rooted (branchify -> (roots, branches, target))) = do newTarget <- foldlM1 mergePointlike =<< fromNullable (toList roots) - let newBranches = mapOSet invertBranch branches + let newBranches = mapOSetNN invertBranch branches Just . Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Pointlike target) newBranches) + (singletonNNMap (Pointlike target) newBranches) newTarget normalizePath :: Path -> NormalizedPath Anchor @@ -365,17 +361,17 @@ normalizePath = \case Wild -> NormalizedPath . singletonSet . Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Pointlike unanchored) (singletonSet (DPOutgoing DPWild))) + (singletonNNMap (Pointlike unanchored) (singletonNNSet (DPOutgoing DPWild))) unanchored Literal t -> NormalizedPath . singletonSet . Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Pointlike unanchored) (singletonSet (DPOutgoing (DPLiteral t)))) + (singletonNNMap (Pointlike unanchored) (singletonNNSet (DPOutgoing (DPLiteral t)))) unanchored RegexMatch r -> NormalizedPath . singletonSet . Rooted $ smartBuildRootedDeterministicPath - (singletonMap (Pointlike unanchored) (singletonSet (DPOutgoing (DPRegex r)))) + (singletonNNMap (Pointlike unanchored) (singletonNNSet (DPOutgoing (DPRegex r)))) unanchored Backwards p -> let np = normalizePath p @@ -429,17 +425,18 @@ leastConstrainedNormalizedPath = let newTarget = convertPointlike target newRootBranches = rootBranches + & toNullable & mapToList & concatMap explodeUnanchored & map (uncurry singletonMap) & unionsWith (<>) in smartBuildRootedDeterministicPath - newRootBranches + (impureNonNull newRootBranches) newTarget explodeUnanchored :: - (DeterministicPath Anchor, OSet (DPBranch Anchor)) -> - [(DeterministicPath FullyAnchored, OSet (DPBranch FullyAnchored))] + (DeterministicPath Anchor, NonNull (OSet (DPBranch Anchor))) -> + [(DeterministicPath FullyAnchored, NonNull (OSet (DPBranch FullyAnchored)))] explodeUnanchored = \case ( Rooted rdp@RootedDeterministicPath {target = PointlikeDeterministicPath {anchor = Unanchored}}, @@ -448,27 +445,28 @@ leastConstrainedNormalizedPath = let RootedDeterministicPath {..} = convertRooted rdp rootBranches' :: [(DeterministicPath FullyAnchored, DPBranch FullyAnchored)] = rootBranches + & toNullable & mapToList & over (mapped . _2) toList & concatMap (\(root, bs) -> map (root,) bs) - branchExtensions' :: OSet (DPBranch FullyAnchored) = unions (mapOSet convertBranch branchExtensions) + branchExtensions' :: OSet (DPBranch FullyAnchored) = unions (mapOSet convertBranch (toNullable branchExtensions)) in (rootBranches' `cartesianProduct` toList branchExtensions') & map ( \((root, b1), b2) -> smartBuildRootBranch root - ( singletonSet $ + ( singletonNNSet $ smartBuildSequence - (singletonSet b1) + (singletonNNSet b1) (PointlikeDeterministicPath (FJoinPoint mempty) mempty) - (singletonSet b2) + (singletonNNSet b2) ) ) (dp, bs) -> singleton $ smartBuildRootBranch (convertDeterministicPath dp) - (unions $ mapOSet convertBranch bs) + (impureNonNull $ unions $ mapOSet convertBranch (toNullable bs)) convertAnchor = \case Unanchored -> FJoinPoint mempty @@ -490,21 +488,21 @@ leastConstrainedNormalizedPath = DPOutgoing t -> singletonSet $ DPOutgoing t DPIncoming t -> singletonSet $ DPIncoming t DPSequence as1 midpoint bs2 -> do - let as1' = unions (mapOSet convertBranch as1) - let bs2' = unions (mapOSet convertBranch bs2) + let as1' = unions (mapOSet convertBranch (toNullable as1)) + let bs2' = unions (mapOSet convertBranch (toNullable bs2)) case midpoint.anchor of Unanchored | null midpoint.loops -> mapOSet ( \(x, y) -> smartBuildSequence - (singletonSet x) + (singletonNNSet x) (convertPointlike joinPoint) - (singletonSet y) + (singletonNNSet y) ) (as1' `cartesianProductSet` bs2') | otherwise -> error "broken invariant: Unanchored path with loops" - _ -> singletonSet $ DPSequence as1' (convertPointlike midpoint) bs2' + _ -> singletonSet $ DPSequence (impureNonNull as1') (convertPointlike midpoint) (impureNonNull bs2') -- | Assign one JoinPoint to each Unanchored anchor leastNodesNormalizedPath :: @@ -535,15 +533,15 @@ traverseAnchors f (NormalizedPath paths) = convertRooted :: RootedDeterministicPath a -> f (RootedDeterministicPath b) convertRooted (RootedDeterministicPath rootBranches target) = - smartBuildRootedDeterministicPath . mapFromList - <$> traverse convertRootBranch (mapToList rootBranches) + smartBuildRootedDeterministicPath . impureNonNull . mapFromList + <$> traverse convertRootBranch (mapToList (toNullable rootBranches)) <*> convertPointlike target where - convertRootBranch :: (DeterministicPath a, OSet (DPBranch a)) -> f (DeterministicPath b, OSet (DPBranch b)) + convertRootBranch :: (DeterministicPath a, NonNull (OSet (DPBranch a))) -> f (DeterministicPath b, NonNull (OSet (DPBranch b))) convertRootBranch (dp, branches) = (,) <$> convertDeterministicPath dp - <*> (setFromList <$> traverse convertBranch (toList branches)) + <*> (impureNonNull . setFromList <$> traverse convertBranch (toList branches)) convertPointlike :: PointlikeDeterministicPath a -> f (PointlikeDeterministicPath b) convertPointlike (PointlikeDeterministicPath anchor loops) = @@ -556,7 +554,7 @@ traverseAnchors f (NormalizedPath paths) = DPOutgoing t -> pure $ DPOutgoing t DPIncoming t -> pure $ DPIncoming t DPSequence as1 midpoint as2 -> - smartBuildSequence . setFromList - <$> traverse convertBranch (toList as1) + smartBuildSequence + <$> (impureNonNull . setFromList <$> traverse convertBranch (toList as1)) <*> convertPointlike midpoint - <*> (setFromList <$> traverse convertBranch (toList as2)) + <*> (impureNonNull . setFromList <$> traverse convertBranch (toList as2)) diff --git a/cli/src/Models/NormalizedPath/Parse.hs b/cli/src/Models/NormalizedPath/Parse.hs index f543ba4..54456e5 100644 --- a/cli/src/Models/NormalizedPath/Parse.hs +++ b/cli/src/Models/NormalizedPath/Parse.hs @@ -53,7 +53,7 @@ pPointlike pNID = label "pointlike" do -- | Parse rooted deterministic path: "[@target", "[branches]" pRootedPath :: Parser NID -> Parser (RootedDeterministicPath Anchor) pRootedPath pNID = label "rooted path" do - rootBranches <- brackets (pRootBranches pNID) + rootBranches <- impureNonNull <$> brackets (pRootBranches pNID) target <- option unanchored (pTarget pNID) pure $ RootedDeterministicPath rootBranches target @@ -63,28 +63,28 @@ pSequence pNID = label "sequence" do (initial, splitFirst -> ((m, b), rest)) <- pSequenceBranchSet pNID `via1` pMidpoint pure . uncurry ($) $ foldl' - (\(acc, x) (n, y) -> (acc . singletonSet . DPSequence x n, y)) - (DPSequence initial m :: OSet (DPBranch Anchor) -> DPBranch Anchor, b :: OSet (DPBranch Anchor)) + (\(acc, x) (n, y) -> (acc . singletonNNSet . DPSequence x n, y)) + (DPSequence initial m :: NonNull (OSet (DPBranch Anchor)) -> DPBranch Anchor, b :: NonNull (OSet (DPBranch Anchor))) rest where pMidpoint = symbol "/" *> option unanchored (pPointlike pNID) <* symbol "|" -- | Parse a set of branches separated by & -pSequenceBranchSet :: Parser NID -> Parser (OSet (DPBranch Anchor)) +pSequenceBranchSet :: Parser NID -> Parser (NonNull (OSet (DPBranch Anchor))) pSequenceBranchSet pNID = label "sequence branch set" $ - try (setFromList <$> pMultiple) - <|> (singletonSet <$> pSingleBranch) + try (impureNonNull . setFromList <$> pMultiple) + <|> (singletonNNSet <$> pSingleBranch) where pMultiple = parens (pBranch pNID `sepBy1` symbol "&") -- | Parse a set of branches separated by & -pRootedBranchSet :: Parser NID -> Parser (OSet (DPBranch Anchor)) +pRootedBranchSet :: Parser NID -> Parser (NonNull (OSet (DPBranch Anchor))) pRootedBranchSet pNID = label "rooted branch set" $ - try (singletonSet <$> pBranch pNID) - <|> (setFromList <$> pMultiple) + try (singletonNNSet <$> pBranch pNID) + <|> (impureNonNull . setFromList <$> pMultiple) where pMultiple = parens (pBranch pNID `sepBy1` symbol "&") @@ -102,14 +102,14 @@ pExplicitAnchor pNID = -- | Parse root branches: "@ - Parser (OMap (DeterministicPath Anchor) (OSet (DPBranch Anchor))) + Parser (OMap (DeterministicPath Anchor) (NonNull (OSet (DPBranch Anchor)))) pRootBranches pNID = label "root branches" do branches <- sepBy1 (pRootBranch pNID) (symbol "&") pure $ unionsWith (<>) $ uncurry singletonMap <$> branches pRootBranch :: Parser NID -> - Parser (DeterministicPath Anchor, OSet (DPBranch Anchor)) + Parser (DeterministicPath Anchor, NonNull (OSet (DPBranch Anchor))) pRootBranch pNID = label "root branch" do root <- option diff --git a/cli/src/Models/NormalizedPath/ParseSpec.hs b/cli/src/Models/NormalizedPath/ParseSpec.hs index 9c1dcc0..1a8e7cf 100644 --- a/cli/src/Models/NormalizedPath/ParseSpec.hs +++ b/cli/src/Models/NormalizedPath/ParseSpec.hs @@ -45,10 +45,10 @@ test_pNormalizedPath = "[@@" `parsesTo` singletonRooted ( RootedDeterministicPath - ( mapFromList - [ (Pointlike joinPoint, singletonSet (DPOutgoing (DPLiteral "a"))), - (Pointlike $ specific (smallNID 1), singletonSet (DPOutgoing (DPLiteral "b"))), - (Pointlike unanchored, singletonSet (DPOutgoing (DPLiteral "c"))) + ( impureNonNull $ mapFromList + [ (Pointlike joinPoint, singletonNNSet (DPOutgoing (DPLiteral "a"))), + (Pointlike $ specific (smallNID 1), singletonNNSet (DPOutgoing (DPLiteral "b"))), + (Pointlike unanchored, singletonNNSet (DPOutgoing (DPLiteral "c"))) ] ) joinPoint @@ -135,13 +135,13 @@ singletonBranch :: DPBranch Anchor -> NormalizedPath Anchor singletonBranch branch = NormalizedPath . singletonSet . Rooted $ RootedDeterministicPath - (singletonMap (Pointlike unanchored) (singletonSet branch)) + (singletonNNMap (Pointlike unanchored) (singletonNNSet branch)) unanchored branches :: [DPBranch Anchor] -> NormalizedPath Anchor branches bs = NormalizedPath . setFromList $ - [ Rooted (RootedDeterministicPath (singletonMap (Pointlike unanchored) (singletonSet b)) unanchored) + [ Rooted (RootedDeterministicPath (singletonNNMap (Pointlike unanchored) (singletonNNSet b)) unanchored) | b <- bs ] diff --git a/cli/src/MyPrelude/Collections.hs b/cli/src/MyPrelude/Collections.hs index ccbed21..5106d4f 100644 --- a/cli/src/MyPrelude/Collections.hs +++ b/cli/src/MyPrelude/Collections.hs @@ -125,6 +125,9 @@ mapSet = Set.map mapOSet :: (Ord b) => (a -> b) -> OSet a -> OSet b mapOSet f = setFromList . map f . toList +mapOSetNN :: (HasCallStack, Ord b) => (a -> b) -> NonNull (OSet a) -> NonNull (OSet b) +mapOSetNN f = impureNonNull . mapOSet f . toNullable + mapFromSet :: (Ord k) => Set k -> Map k () mapFromSet = Map.fromSet (const ()) @@ -287,3 +290,11 @@ ixsetmapped = iso IxSet.toSet IxSet.fromSet . setmapped nnmap :: (HasCallStack, MonoFoldable (f b), Functor f) => (a -> b) -> NonNull (f a) -> NonNull (f b) nnmap f = impureNonNull . fmap f . toNullable + +traverseNonNull :: + (HasCallStack, MonoFoldable (f b), Traversable f, Applicative g) => + (a -> g b) -> + NonNull (f a) -> + g (NonNull (f b)) +traverseNonNull f = fmap impureNonNull . traverse f . toNullable +