-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
module Data.TreeSeq.Strict.Zipper where
import Control.Applicative (Applicative(..), Alternative(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Int (Int)
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
-import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>))
import Data.Typeable (Typeable)
import Prelude (undefined)
import Text.Show (Show(..))
-import qualified Data.Sequence as Seq
import qualified Data.List as List
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Sequence as Seq
import Data.TreeSeq.Strict (Trees, Tree(..))
nodesTree Tree0{} = mempty
nodesTree (TreeN _k ts) = ts
-keyTree :: Tree k a -> k
-keyTree (TreeN k _) = k
-keyTree Tree0{} = undefined
-
-- * Type 'Zipper'
-data Zipper k a
- = Zipper
- { zipper_path :: [Zipper_Step k a]
- , zipper_curr :: Trees k a
- } deriving (Eq, Show, Typeable)
+type Zipper k a = NonEmpty (Node k a)
+
+zipper :: Tree k a -> Zipper k a
+zipper t = Node mempty t mempty :| []
+
+zippers :: Trees k a -> [Zipper k a]
+zippers ts = ns >>= axis_collect axis_following_first
+ where ns =
+ case Seq.viewl ts of
+ EmptyL -> empty
+ l :< ls -> pure $ Node mempty l ls :| []
+
+zipper_root :: Zipper k a -> Tree k a
+zipper_root =
+ zip_self .
+ NonEmpty.head .
+ List.last .
+ axis_ancestor_or_self
+
+path :: Zipper k x -> [k]
+path ns =
+ List.reverse $
+ NonEmpty.toList ns >>= \n ->
+ case zip_self n of
+ TreeN k _ -> [k]
+ Tree0{} -> []
+
+current :: Zipper k a -> Tree k a
+current (Node _ t _ :| _) = t
+
+at :: Alternative f =>
+ Axis k a -> Int ->
+ (Zipper k a -> f (Zipper k a))
+at axis i n =
+ case List.drop i (axis n) of
+ [] -> empty
+ a:_ -> pure a
+infixl 5 `at`
-zipper :: Trees k a -> Zipper k a
-zipper = Zipper []
+null :: Axis k a -> Zipper k a -> Bool
+null axis = List.null . axis
-zipper_root :: Zipper k a -> Trees k a
-zipper_root = zipper_curr . List.last . zipper_ancestor_or_self
+-- ** Type 'Node'
+data Node k a
+ = Node
+ { zip_prec :: Trees k a
+ , zip_self :: Tree k a
+ , zip_foll :: Trees k a
+ } deriving (Eq, Show, Typeable)
-path_of_zipper :: Zipper k x -> [k]
-path_of_zipper z =
- keyTree . zipper_step_self <$>
- List.reverse (zipper_path z)
+-- * Type 'Axis'
+type Axis k a = Zipper k a -> [Zipper k a]
--- * Type 'Zipper_Step'
-data Zipper_Step k a
- = Zipper_Step
- { zipper_step_prec :: Trees k a
- , zipper_step_self :: Tree k a
- , zipper_step_foll :: Trees k a
- } deriving (Eq, Show, Typeable)
+-- ** Type 'AxisAlt'
+-- | Like 'Axis', but generalized with 'Alternative'.
+--
+-- Useful to return a 'Maybe' instead of a list.
+type AxisAlt f k a = Alternative f => Zipper k a -> f (Zipper k a)
--- * Axis
-- | Collect all 'Zipper's along a given axis,
-- including the first 'Zipper'.
-zipper_collect :: (z -> Maybe z) -> z -> [z]
-zipper_collect f z = z : maybe [] (zipper_collect f) (f z)
+axis_collect :: (n -> Maybe n) -> n -> [n]
+axis_collect f n = n : maybe [] (axis_collect f) (f n)
-- | Collect all 'Zipper's along a given axis,
-- excluding the first 'Zipper'.
-zipper_collect_without_self :: (z -> Maybe z) -> z -> [z]
-zipper_collect_without_self f z = maybe [] (zipper_collect f) (f z)
+axis_collect_without_self :: (n -> Maybe n) -> n -> [n]
+axis_collect_without_self f n = maybe [] (axis_collect f) (f n)
-- ** Axis self
-zipper_self :: Zipper k a -> [Tree k a]
-zipper_self (Zipper (Zipper_Step _ t _ : _) _) = [t]
-zipper_self _ = []
+axis_self :: Applicative f => Zipper k a -> f (Tree k a)
+axis_self (Node _ t _ :| _) = pure t
-- ** Axis child
-zipper_child :: Zipper k a -> [Zipper k a]
-zipper_child z =
- zipper_child_first z >>=
- zipper_collect zipper_foll
-
-zipper_child_lookup ::
- Alternative f =>
- (k -> Bool) -> Zipper k a -> f (Zipper k a)
-zipper_child_lookup fk z = safeHead $ zipper_childs_lookup fk z
-
-zipper_childs_lookup ::
- (k -> Bool) -> Zipper k a -> [Zipper k a]
-zipper_childs_lookup fk (Zipper path ts) =
- (<$> Seq.findIndicesL (\case TreeN k _ -> fk k; Tree0{} -> False) ts) $ \i ->
- let (ps, ps') = Seq.splitAt i ts in
+axis_child :: Axis k a
+axis_child n =
+ axis_child_first n >>=
+ axis_collect axis_following_first
+
+axis_child_lookup_first :: (k -> Bool) -> AxisAlt f k a
+axis_child_lookup_first fk n = safeHead $ axis_child_lookup fk n
+
+axis_child_lookup :: (k -> Bool) -> Axis k a
+axis_child_lookup fk ns@(Node _ps t _fs :| _) =
+ (<$> Seq.findIndicesL flt cs) $ \i ->
+ let (ps, ps') = Seq.splitAt i cs in
case Seq.viewl ps' of
EmptyL -> undefined
- t :< fs ->
- Zipper
- { zipper_path = Zipper_Step ps t fs : path
- , zipper_curr = nodesTree t
- }
-
-zipper_child_first :: Alternative f => Zipper k a -> f (Zipper k a)
-zipper_child_first (Zipper path trees) =
- case Seq.viewl trees of
+ l :< ls -> Node ps l ls :| NonEmpty.toList ns
+ where
+ cs = nodesTree t
+ flt (TreeN k _) = fk k
+ flt Tree0{} = False
+
+axis_child_first :: AxisAlt f k a
+axis_child_first ns@(Node _ps t _fs :| _) =
+ case Seq.viewl $ nodesTree t of
EmptyL -> empty
- t :< ts -> pure $ Zipper
- { zipper_path = Zipper_Step mempty t ts : path
- , zipper_curr = nodesTree t
- }
-
-zipper_child_last :: Alternative f => Zipper k a -> f (Zipper k a)
-zipper_child_last (Zipper path trees) =
- case Seq.viewr trees of
+ l :< ls -> pure $ Node mempty l ls :| NonEmpty.toList ns
+
+axis_child_last :: AxisAlt f k a
+axis_child_last ns@(Node _ps t _fs :| _) =
+ case Seq.viewr $ nodesTree t of
EmptyR -> empty
- ts :> t -> pure $ Zipper
- { zipper_path = Zipper_Step ts t mempty : path
- , zipper_curr = nodesTree t
- }
+ rs :> r -> pure $ Node rs r mempty :| NonEmpty.toList ns
-- ** Axis ancestor
-zipper_ancestor :: Zipper k a -> [Zipper k a]
-zipper_ancestor = zipper_collect_without_self zipper_parent
+axis_ancestor :: Axis k a
+axis_ancestor = axis_collect_without_self axis_parent
-zipper_ancestor_or_self :: Zipper k a -> [Zipper k a]
-zipper_ancestor_or_self = zipper_collect zipper_parent
+axis_ancestor_or_self :: Axis k a
+axis_ancestor_or_self = axis_collect axis_parent
-- ** Axis descendant
-zipper_descendant_or_self :: Zipper k a -> [Zipper k a]
-zipper_descendant_or_self =
+axis_descendant_or_self :: Axis k a
+axis_descendant_or_self =
collect_child []
where
- collect_child acc z =
- z : maybe acc
- (collect_foll acc)
- (zipper_child_first z)
- collect_foll acc z =
- collect_child
- (maybe acc
- (collect_foll acc)
- (zipper_foll z)
- ) z
-
-zipper_descendant_or_self_reverse :: Zipper k a -> [Zipper k a]
-zipper_descendant_or_self_reverse z =
- z : List.concatMap
- zipper_descendant_or_self_reverse
- (List.reverse $ zipper_child z)
-
-zipper_descendant :: Zipper k a -> [Zipper k a]
-zipper_descendant = List.tail . zipper_descendant_or_self
+ collect_child acc n =
+ n : maybe acc
+ (collect_following_first acc)
+ (axis_child_first n)
+ collect_following_first acc n =
+ collect_child
+ (maybe acc
+ (collect_following_first acc)
+ (axis_following_first n)
+ ) n
+
+axis_descendant_or_self_reverse :: Axis k a
+axis_descendant_or_self_reverse n =
+ n :
+ List.concatMap
+ axis_descendant_or_self_reverse
+ (List.reverse $ axis_child n)
+
+axis_descendant :: Axis k a
+axis_descendant = List.tail . axis_descendant_or_self
-- ** Axis preceding
-zipper_prec :: Alternative f => Zipper k a -> f (Zipper k a)
-zipper_prec (Zipper [] _curr) = empty
-zipper_prec (Zipper (Zipper_Step ps c fs : path) _curr) =
+axis_preceding_first :: AxisAlt f k a
+axis_preceding_first (Node ps t fs :| ns) =
case Seq.viewr ps of
EmptyR -> empty
- ts :> t -> pure Zipper
- { zipper_path = Zipper_Step ts t (c <| fs) : path
- , zipper_curr = nodesTree t
- }
+ rs :> r -> pure $ Node rs r (t <| fs) :| ns
-zipper_preceding :: Zipper k a -> [Zipper k a]
-zipper_preceding =
- zipper_ancestor_or_self >=>
- zipper_preceding_sibling >=>
- zipper_descendant_or_self_reverse
+axis_preceding_sibling :: Axis k a
+axis_preceding_sibling = axis_collect_without_self axis_preceding_first
-zipper_preceding_sibling :: Zipper k a -> [Zipper k a]
-zipper_preceding_sibling = zipper_collect_without_self zipper_prec
+axis_preceding :: Axis k a
+axis_preceding =
+ axis_ancestor_or_self >=>
+ axis_preceding_sibling >=>
+ axis_descendant_or_self_reverse
-- ** Axis following
-zipper_foll :: Alternative f => Zipper k a -> f (Zipper k a)
-zipper_foll (Zipper [] _curr) = empty
-zipper_foll (Zipper (Zipper_Step ps c fs:path) _curr) =
+axis_following_first :: AxisAlt f k a
+axis_following_first (Node ps t fs :| ns) =
case Seq.viewl fs of
EmptyL -> empty
- t :< ts -> pure $ Zipper
- { zipper_path = Zipper_Step (ps |> c) t ts : path
- , zipper_curr = nodesTree t
- }
+ l :< ls -> pure $ Node (ps |> t) l ls :| ns
-zipper_following :: Zipper k a -> [Zipper k a]
-zipper_following =
- zipper_ancestor_or_self >=>
- zipper_following_sibling >=>
- zipper_descendant_or_self
+axis_following_sibling :: Axis k a
+axis_following_sibling = axis_collect_without_self axis_following_first
-zipper_following_sibling :: Zipper k a -> [Zipper k a]
-zipper_following_sibling = zipper_collect_without_self zipper_foll
+axis_following :: Axis k a
+axis_following =
+ axis_ancestor_or_self >=>
+ axis_following_sibling >=>
+ axis_descendant_or_self
-- ** Axis parent
-zipper_parent :: Alternative f => Zipper k a -> f (Zipper k a)
-zipper_parent (Zipper [] _) = empty
-zipper_parent (Zipper (Zipper_Step ps c fs : path) curr) =
- pure Zipper
- { zipper_path = path
- , zipper_curr = (ps |> m) <> fs
- }
- where
- m = case c of
- TreeN k _ -> TreeN k curr
- Tree0{} -> undefined
+axis_parent :: AxisAlt f k a
+axis_parent (Node ps t fs :| ns) =
+ case ns of
+ Node ps' (TreeN k _) fs' : ns' ->
+ pure $ Node ps' (TreeN k $ (ps |> t) <> fs) fs' :| ns'
+ _ -> empty
-- ** Filter
-zipper_filter ::
- (Zipper k a -> [Zipper k a]) ->
- (Zipper k a -> Bool) ->
- (Zipper k a -> [Zipper k a])
-zipper_filter axis p z = List.filter p (axis z)
-infixl 5 `zipper_filter`
-
-zipper_at ::
- Alternative f =>
- (Zipper k a -> [Zipper k a]) -> Int ->
- (Zipper k a -> f (Zipper k a))
-zipper_at axis n z =
- case List.drop n (axis z) of
- [] -> empty
- a:_ -> pure a
-infixl 5 `zipper_at`
-
-zipper_null ::
- (Zipper k a -> [Zipper k a]) ->
- Zipper k a -> Bool
-zipper_null axis = List.null . axis
+axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
+axis_filter axis p n = List.filter p (axis n)
+infixl 5 `axis_filter`
-- import Prelude (Num(..), undefined)
-- import qualified Control.Monad.Trans.State as S
-- import qualified Data.Map.Strict as Map
-import Control.Monad (forM_, mapM_, when)
+import Control.Monad (forM_, mapM_, when, (>=>))
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
import Data.Foldable (Foldable(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Tuple (snd)
import Prelude (Num(..))
import Text.Blaze ((!))
import Text.Blaze.Html (Html)
import Text.Show (Show(..))
+import Data.TreeSeq.Strict (Tree(..))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as H
+-- import qualified Data.TreeSeq.Strict as Tree
+import qualified Data.TreeSeq.Strict.Zipper as Tree
import Text.Blaze.Utils
instance H.ToMarkup DTC.Ident where
toMarkup (DTC.Ident i) = H.toMarkup i
+instance H.ToMarkup DTC.Title where
+ toMarkup (DTC.Title t) = html5Horizontals t
instance AttrValue XmlPos where
attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
H.meta ! HA.httpEquiv "Content-Type"
! HA.content "text/html; charset=UTF-8"
whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
- let t = textHorizontals $ List.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
+ let t = H.toMarkup $ List.head $ ts <> [DTC.Title [DTC.Plain ""]] in
H.title $ H.toMarkup t
-- link ! rel "Chapter" ! title "SomeTitle">
H.link ! HA.rel "stylesheet"
H.body $
html5Body inh body
-html5Body :: InhHtml5 -> [DTC.Body] -> Html
-html5Body _inh [] = mempty
-html5Body inh@InhHtml5{..} (b:bs) =
- case b of
- DTC.Section{..} -> do
+-- * Type 'BodyZip'
+type BodyZip = Tree.Zipper DTC.BodyKey (Seq DTC.BodyValue)
+
+html5Body :: InhHtml5 -> DTC.Body -> Html
+html5Body inh body =
+ forM_ (Tree.zippers body) $
+ html5BodyZipper inh
+
+html5BodyZipper :: InhHtml5 -> BodyZip -> Html
+html5BodyZipper inh z =
+ case Tree.current z of
+ TreeN k _ts -> html5BodyKey inh z k
+ Tree0 vs -> forM_ vs $ html5BodyValue inh z
+
+html5BodyKey :: InhHtml5 -> BodyZip -> DTC.BodyKey -> Html
+html5BodyKey inh z = \case
+ DTC.Section{..} ->
H.section
! HA.class_ "section"
! HA.id (attrValue pos) $ do
H.td ! HA.class_ "section-number" $ do
html5SectionNumber $ xmlPosAncestors pos
H.td ! HA.class_ "section-title" $ do
- html5Horizontals $ DTC.unTitle title
- html5Body inh body
- html5Body inh bs
- {- aliases :: [Alias]
- -}
- DTC.Verticals vs -> do
- html5Verticals vs
- html5Body inh bs
+ H.toMarkup title
+ forM_ (Tree.axis_child z) $
+ html5BodyZipper inh
+
+html5BodyValue :: InhHtml5 -> BodyZip -> DTC.BodyValue -> Html
+html5BodyValue InhHtml5{..} z = \ case
+ DTC.Vertical v -> do
+ html5Vertical v
DTC.ToC{..} -> do
H.nav ! HA.class_ "toc"
! HA.id (attrValue pos) $ do
H.a ! HA.href (attrValue pos) $
inhHtml5_localize MsgHTML5_Table_of_Contents
H.ul $
- html5ToC d bs
- html5Body inh bs
+ forM_ (Tree.axis_following_sibling z) $
+ html5ToC d
where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
DTC.ToF{..} -> do
H.nav ! HA.class_ "tof"
! HA.id (attrValue pos) $
- ""
- html5Body inh bs
+ H.table ! HA.class_ "tof" $
+ H.tbody $
+ forM_ (Tree.axis_preceding z) $
+ html5ToF d
+ where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 }
+ DTC.Figure{..} ->
+ html5CommonAttrs attrs $
+ H.div ! HA.class_ (attrValue $ "figure-"<>type_)
+ ! HA.id (attrValue pos) $ do
+ H.table ! HA.class_ "figure-caption" $
+ H.tbody $
+ H.tr $ do
+ H.td ! HA.class_ "figure-number" $ do
+ H.a ! HA.href "" $ H.toMarkup type_
+ ": "
+ H.td ! HA.class_ "figure-name" $
+ H.toMarkup title
+ H.div ! HA.class_ "figure-content" $ do
+ html5Verticals verts
-html5ToC :: Int -> [DTC.Body] -> Html
-html5ToC _depth [] = mempty
-html5ToC depth (b:bs) =
- case b of
- DTC.Section{..} -> do
+html5ToC :: Int -> BodyZip -> Html
+html5ToC depth z =
+ case Tree.current z of
+ TreeN DTC.Section{..} _ts -> do
H.li $ do
H.table ! HA.class_ "toc-entry" $
H.tbody $
H.td $
html5SectionRef $ xmlPosAncestors pos
H.td $
- html5Horizontals $ DTC.unTitle title
+ H.toMarkup title
when (depth > 0) $
- H.ul $ html5ToC (depth - 1) body
- html5ToC depth bs
- _ -> html5ToC depth bs
+ H.ul $
+ forM_ (Tree.axis_child z) $
+ html5ToC (depth - 1)
+ _ -> mempty
+
+html5ToF :: Int -> BodyZip -> Html
+html5ToF depth z =
+ case Tree.current z of
+ Tree0 bs ->
+ forM_ bs $ \case
+ DTC.Figure{..} ->
+ H.tr $ do
+ H.td ! HA.class_ "figure-number" $
+ H.a ! HA.href (attrValue pos) $
+ H.toMarkup type_
+ H.td ! HA.class_ "figure-name" $
+ H.toMarkup title
+ _ -> mempty
+ _ -> mempty
textXmlPosAncestors :: [(XmlName,Int)] -> Text
textXmlPosAncestors =
forM_ refs html5Reference
DTC.Comment t ->
H.Comment (H.Text t) ()
- DTC.Figure{..} ->
- html5CommonAttrs attrs $
- H.div ! HA.class_ (attrValue $ "figure-"<>type_)
- ! HA.id (attrValue pos) $ do
- H.table ! HA.class_ "figure-caption" $
- H.tbody $
- H.tr $ do
- H.td ! HA.class_ "figure-number" $ do
- H.a ! HA.href "" $ H.toMarkup type_
- ": "
- H.td ! HA.class_ "figure-name" $
- html5Horizontals $ DTC.unTitle title
- H.div ! HA.class_ "figure-content" $ do
- html5Verticals verts
{-
Index{..} ->
Artwork{..} ->
sourcephile / git / doclang.git / commitdiff