current = `module Main where import Prelude import Debug import Control.Comonad.Cofree (head, tail) import Data.Array as A import Data.Either (Either(..), either) import Data.Enum import Data.Enum.Generic import Data.List (List(..), (:), drop) import Data.List (head, tail) as L import Data.Maybe (Maybe(..), maybe, isNothing, fromJust) import Data.Foldable (foldMap, foldl) import Data.Generic.Rep (class Generic) import Partial.Unsafe (unsafePartial, unsafeCrashWith) import Data.Profunctor (wrapIso) import Foreign (Foreign) import Data.Newtype (class Newtype) import Data.NonEmpty (NonEmpty, (:|), singleton) import Data.NonEmpty as NE import Data.Show.Generic (genericShow) import Yoga.Tree (Tree, mkTree, appendChild) import Yoga.Tree.Zipper as TZ import Data.Tuple import Data.Tuple.Nested import Data.Codec.Foreign as F import Data.Codec.Foreign.Record as FR import Data.Codec.Foreign.Common as FC -- newtype Loc a = Loc -- { node :: Tree a -- , before :: Forest a -- , after :: Forest a -- , parents :: List (Loc a) -- } -- insertChild :: forall a. Tree a -> Loc a -> Loc a -- insertChild n l = -- case down l of -- Just c -> insertAfter n c -- Nothing -> Loc -- { node: n -- , after: Nil -- , before: Nil -- , parents: l : (parents l) -- } -- | Insert a node as a child to the current node, and DO NOT move cursor to the new node. insertChild' :: forall a. Tree a -> TZ.Loc a -> TZ.Loc a insertChild' n (TZ.Loc l@{node}) = let n' = appendChild n node in TZ.Loc $ l { node = n' } data BlockType = Doc | H1 | H2 | H3 | H4 | H5 | H6 | L | I | T | P | Q | LISTMARK | SKIP derive instance Eq BlockType derive instance Ord BlockType derive instance Generic BlockType _ instance Bounded BlockType where top = SKIP bottom = Doc instance Enum BlockType where pred = genericPred succ = genericSucc instance BoundedEnum BlockType where cardinality = genericCardinality toEnum = genericToEnum fromEnum = genericFromEnum instance Show BlockType where show = genericShow newtype Block = Block { block :: BlockType , content :: Maybe String , children :: Array Block } derive instance Eq Block derive instance Newtype Block _ derive instance Generic Block _ instance Show Block where show (Block {block, content, children}) = "

" <> show block <> ": " <> maybe "" identity content <> "" <> foldMap show children <> "

" block ∷ F.ForeignCodec Block block = F.fix \codec → wrapIso Block $ FR.object "Block" { block: blockTypeCodec , content: FR.optional F.string , children: FC.array codec } blockTypeCodec :: F.ForeignCodec BlockType blockTypeCodec = F.prismaticCodec "BlockType" dec enc F.string where dec = case _ of "Document" -> Just Doc "h1" -> Just H1 "h2" -> Just H2 "h3" -> Just H3 "h4" -> Just H4 "h5" -> Just H5 "h6" -> Just H6 "p" -> Just P "l" -> Just L "i" -> Just I "t" -> Just T "q" -> Just Q "ListMark" -> Just LISTMARK _ -> Just SKIP enc = case _ of Doc -> "Document" _ -> "TODO" type Blocky = { block :: BlockType, content :: Maybe String } -- type Tree a = Cofree List a type BlockTree = Tree Blocky showBlockTree :: BlockTree -> String showBlockTree bt = "

" <> show block <> ": " <> maybe "" identity content <> children <> "

" where { block, content } = head bt children = foldMap showBlockTree $ tail bt input :: Foreign -> Maybe Block input f = either (const Nothing) Just (F.decode block f) blockTree :: Block -> BlockTree blockTree (Block { block, content, children } ) = mkTree { block, content } $ blockTree <$> children unBlockTree :: BlockTree -> Block unBlockTree bt = case head bt, tail bt of { block, content }, t -> Block { block, content, children: unBlockTree <$> t } -- transformBlockTree :: BlockTree -> BlockTree -- transformBlockTree orig = transformed -- where -- zipped = TZ.fromTree orig -- newRoot = TZ.fromTree $ mkTree (TZ.value zipped) Nil -- -- Under root, check for h1s. For each h1, get indexes. -- children = TZ.children zipped -- -- scanl :: forall a b f. Traversable f => (b -> a -> b) -> b -> f a -> f b -- -- foldl :: forall a b. (b -> a -> b) -> b -> f a -> b -- headings level { seenH, res } child -- | not seenH && (head child).name == "h" <> level -- -- first heading, append heading to new root and move after new child -- = { seenH: true, res: TZ.insertChild child res } -- | seenH && (head child).name == "h" <> level -- -- additional headings, move back up out of current heading, append heading and move to new child -- = { seenH, res: unsafePartial $ TZ.insertChild child (fromJust $ TZ.up $ res) } -- | not seenH -- -- top level outside of h1 blocks -- = { seenH, res: insertChild' child res } -- | otherwise -- -- append anything else to h1 and don't move -- = { seenH, res: insertChild' child res } -- { res: res1 } = foldl (headings "1") { seenH: false, res: newRoot } children -- { res } = foldl (headings "2") { seenH: false, res: TZ.root res1 } $ TZ.children res1 -- -- { res: res3 } = foldl (headings "3") { seenH: false, res: TZ.root res2 } $ TZ.children res2 -- -- { res } = foldl (headings "4") { seenH: false, res: TZ.root res3 } $ TZ.children res3 -- -- transformed = TZ.toTree zipped -- transformed = TZ.toTree res showTransform :: Foreign -> String showTransform f = "

original	transformed
" <> orig <> "	" <> bt <> "

" where orig = either show show $ F.decode block f inp = input f bt = maybe "" showBlockTree $ (transformBlockTree <<< blockTree) <$> inp -- transform val = case runExcept $ readBlock val of -- Left errs -> foldMap show errs -- Right block -> show block -- transformBlockTree = identity type BlockAcc = { spine :: NonEmpty List BlockType, cursor :: TZ.Loc Blocky } blk :: BlockTree -> BlockType blk child = (head child).block push :: forall a. a -> NonEmpty List a -> NonEmpty List a push a (b :| rest) = a :| b : rest pop :: forall a. NonEmpty List a -> Either a (Tuple a (NonEmpty List a)) pop (a :| rest) = case L.head rest, L.tail rest of Just b, Just c -> Right (Tuple a (b :| c)) _, _ -> Left a unsafePop :: forall a. NonEmpty List a -> Tuple a (NonEmpty List a) unsafePop (a :| rest ) = case L.head rest, L.tail rest of Just b, Just c -> Tuple a (b:| c) _, _ -> unsafeCrashWith "Spine invariants don't hold in blocky tree input. This code is flawed, please review." unsafePop' :: forall a. NonEmpty List a -> NonEmpty List a unsafePop' = snd <<< unsafePop transformBlockTree :: BlockTree -> BlockTree transformBlockTree orig = transformed where zipped = TZ.fromTree orig newRoot = TZ.fromTree $ mkTree (TZ.value zipped) [] {cursor} = foldl blocky { spine: singleton Doc , cursor: newRoot } $ TZ.children zipped transformed = TZ.toTree cursor transform :: Foreign -> Foreign transform f = F.encode block $ unBlockTree $ transformBlockTree $ case F.decode block f of Left err -> unsafeCrashWith $ show err Right f -> blockTree f -- semantics -- in this case -- # a -- ### b -- ## c -- insert a b' empty H2 between a and b -- - a -- - b' <-- empty H2 -- - b -- - c blocky :: BlockAcc -> BlockTree -> BlockAcc blocky { spine, cursor } c -- #, ## | blk c <= H6 && ( blk c > NE.head spine) = spyWith "downwards" (\{spine: newSpine} -> "\n b: " <> show (blk c) <> "\n spine: " <> show spine <> "\n newSpine: " <> show newSpine <> "\n cursor: " <> show (TZ.value cursor).block) { spine: push (blk c) spine, cursor: TZ.insertChild c cursor } -- ##, # | blk c <= H6 && ( blk c <= NE.head spine) = spyWith "upwards" (\_ -> "\n b: " <> show (blk c) <> "\n spine: " <> show spine <> "\n cursor: " <> show (TZ.value cursor).block) $ reattach c { spine, cursor } -- | blk c <= H6 = spyWith "blocky.reattach" (\_ -> "b: " <> show (blk c) <> " / spine: " <> show spine) $ reattach c { spine, cursor } | blk c > H6 = spyWith "leaf" (\_ -> "\n b: " <> show (blk c) <> "\n spine: " <> show spine <> "\n cursor: " <> show (TZ.value cursor).block) { spine, cursor: insertChild' c cursor } | otherwise = { spine, cursor } -- We're seeing an upper container, so we need to go back up the spine to know how to attach it reattach :: BlockTree -> BlockAcc -> BlockAcc reattach c acc@{ spine, cursor } = spyWith "reattach" (\_ -> "\n spine: " <> show spine <> "\n newSpine: " <> show newSpine <> "\n cursor: " <> show (TZ.value cursor).block <> " / " <> (foldMap show (blk <$> TZ.children cursor)) <> "\n newCursor: " <> show (TZ.value newCursor).block <> " / " <> (foldMap show (blk <$> TZ.children newCursor))) { spine: newSpine, cursor: TZ.insertAfter c $ unsafePartial $ fromJust $ TZ.lastChild newCursor } where -- find the top most container, if it already has a child of our level we're good. -- if not we need to elongate the spine with an empty container level (see semantics above). -- we leave the cursor at the right place to insert the child findContainer :: BlockType -> BlockAcc -> BlockAcc findContainer b acc@{spine, cursor} = case pop spine of Left d | d == Doc -> elongate acc -- we've backtracked all the way to the root, so we'll need to elongate | otherwise -> unsafeCrashWith "Invariant don't hold. No Doc block type at the root." Right (lv /\ sp) -- we've found the level in the spine. we return the spine as it is, and position the cursor up. | b == lv -> spyWith "b == lv" (\_ -> "\n b: " <> show b <> "\n lv: " <> show lv <> "\n sp: " <> show sp <> "\n cursor: " <> show (TZ.value cursor).block <> " / " <> (foldMap show (blk <$> TZ.children cursor))) { spine, cursor: unsafePartial $ fromJust $ TZ.up cursor } -- we've found a smaller container, we continue up. | b < lv -> spyWith "b < lv" (\_ -> "\n b: " <> show b <> "\n lv: " <> show lv <> "\n cursor: " <> show (TZ.value cursor).block <> " / " <> (foldMap show (blk <$> TZ.children cursor))) $ findContainer b { spine: sp, cursor: unsafePartial $ fromJust $ TZ.up cursor } -- we've backtracked and found a larger container, we need to elongate | otherwise -> spyWith "otherwise" (\_ -> "\n b: " <> show b <> "\n lv: " <> show lv) $ elongate { spine: sp, cursor } elongate :: BlockAcc -> BlockAcc elongate = identity { spine: newSpine, cursor: newCursor } = findContainer (blk c) acc`